
   0 | -- SPDX-FileCopyrightText: 2021 The toml-idr developers
   1 | --
   2 | -- SPDX-License-Identifier: MPL-2.0
   3 | 
   4 | module Language.TOML
   5 | 
   6 | 
   7 | import Data.List
   8 | import Data.List1
   9 | import Data.SortedMap
  10 | 
  11 | import Text.Bounded
  12 | import Text.Token
  13 | import Language.TOML.Lexer
  14 | import Language.TOML.Parser
  15 | import public Language.TOML.Value
  16 | import Language.TOML.ConcreteSyntax as C
  17 | 
  18 | 
  19 | 
  20 | private
  21 | data SectionIdent = SGlobal
  22 |                   | STable CKey
  23 |                   | STableArray CKey
  24 | 
  25 | toPair : Item -> Maybe (CKey,CValue)
  26 | toPair (IKeyValue key val) = Just (key,val)
  27 | toPair (ITableHeader _)    = Nothing
  28 | toPair (ITableArray _)     = Nothing
  29 | 
  30 | takeWhileJust : (a -> Maybe b) -> List a -> (List b, List a)
  31 | takeWhileJust f [] = ([],[])
  32 | takeWhileJust f (x :: xs) = case f x of
  33 |   Nothing => ([],x :: xs)
  34 |   Just vb => let (bs,as) = takeWhileJust f xs in (vb :: bs, as)
  35 | 
  36 | 
  37 | private
  38 | sections : List C.Item -> List (SectionIdent, List (CKey, CValue))
  39 | sections xs = loop SGlobal xs
  40 |     where
  41 |         loop : SectionIdent -> List C.Item -> List (SectionIdent, List (CKey, CValue))
  42 |         loop sec [] = []
  43 |         loop sec ((ITableHeader header) :: xs) = loop (STable header) xs
  44 |         loop sec ((ITableArray header) :: xs) = loop (STableArray header) xs
  45 |         loop sec xs =
  46 |             let (kvs, rest) = takeWhileJust toPair xs
  47 |              in (sec, kvs) :: loop sec rest
  48 | 
  49 | 
  50 | public export
  51 | data Error = ErrDottedIsNotATable Key Value
  52 |            | LexerError
  53 |            | ParseError (List String)
  54 |            | Unimplemented
  55 | 
  56 | 
  57 | public export
  58 | Show Error where
  59 |     show (ErrDottedIsNotATable x y) = "Dotted key part `" ++ show x ++ "`is not a table"
  60 |     show LexerError = "Lexer error"
  61 |     show (ParseError x) = "Parse error: " ++ show x
  62 |     show Unimplemented = "Unimplemented feature"
  63 | 
  64 | private
  65 | keyAtomStr : CKeyAtom -> Key
  66 | keyAtomStr (CKBare x) = x
  67 | keyAtomStr (CKQuoted x) = x
  68 | 
  69 | private
  70 | keyParts : CKey -> List1 Key
  71 | keyParts (CKAtom x) = keyAtomStr x ::: []
  72 | keyParts (CKDotted x) = map keyAtomStr x
  73 | 
  74 | public export
  75 | Eq CKeyAtom where
  76 |     x == y = keyAtomStr x == keyAtomStr y
  77 | 
  78 | public export
  79 | Eq CKey where
  80 |     x == y = keyParts x == keyParts y
  81 | 
  82 | private
  83 | tableSetWithParts : (t : Table) -> (path : List1 Key) -> (val : Value) -> Either Error Table
  84 | tableSetWithParts t (head ::: []) val = pure $ insert head val t
  85 | tableSetWithParts t (head ::: (x :: xs)) val = do
  86 |     inner <- case lookup head t of
  87 |                     Nothing => pure empty
  88 |                     Just (VTable t) => pure t
  89 |                     Just v => Left $ ErrDottedIsNotATable head v
  90 |     
  91 |     inner' <- tableSetWithParts inner (x ::: xs) val
  92 |     pure $ insert head (VTable inner') t
  93 | 
  94 | 
  95 | mutual
  96 | 
  97 |     private
  98 |     cvalToVal : CValue -> Either Error Value
  99 |     cvalToVal (CVString x) = pure $ VString x
 100 |     cvalToVal (CVInteger x) = pure $ VInteger x
 101 |     cvalToVal (CVFloat x) = pure $ VFloat x
 102 |     cvalToVal (CVBoolean x) = pure $ VBoolean x
 103 |     cvalToVal (CVArray xs) = map VArray $ for xs cvalToVal
 104 |     cvalToVal (CVInlineTable xs) = map VTable $ tableFromKVs xs
 105 | 
 106 |     private
 107 |     tableFromKVs : List (CKey, CValue) -> Either Error Table
 108 |     tableFromKVs xs = loop empty xs
 109 |         where
 110 |             loop : Table -> List (CKey, CValue) -> Either Error Table
 111 |             loop t [] = Right t
 112 |             loop t ((k, v) :: xs) = do
 113 |                 v' <- cvalToVal v
 114 |                 let parts = keyParts k
 115 |                 t' <- tableSetWithParts t parts v'
 116 |                 loop t' xs
 117 | 
 118 | private
 119 | extendFile : (file : Table) -> (sects : List (SectionIdent, List (CKey, CValue))) -> Either Error Table
 120 | extendFile file [] = pure file
 121 | extendFile file ((SGlobal, kvs) :: rest) = do
 122 |     tab <- tableFromKVs kvs
 123 |     extendFile (mergeLeft tab file) rest
 124 | extendFile file (((STable key), kvs) :: rest) = do
 125 |     tab <- tableFromKVs kvs
 126 |     let kParts = keyParts key
 127 |     file' <- tableSetWithParts file kParts (VTable tab)
 128 |     extendFile file' rest
 129 | 
 130 | extendFile file rest@(((STableArray key), kvs) :: _) = do
 131 |     let (array, rest') = partition
 132 |             (\(sect, _) => case sect of
 133 |                 (STableArray key') => key == key'
 134 |                 _ => False)
 135 |             rest
 136 |     array' <- traverse (map VTable . tableFromKVs) (map snd array)
 137 |     file' <- tableSetWithParts file (keyParts key) (VArray array')
 138 |     extendFile file' rest'
 139 | 
 140 | export
 141 | parseTOML : (src : String) -> Either Error Table
 142 | parseTOML src = do
 143 |     let Just toks = lexTOML src
 144 |         | Nothing => Left LexerError
 145 | 
 146 |     items <- bimap ParseError id (parseItems toks)
 147 | 
 148 |     let sects = sections items
 149 | 
 150 |     extendFile empty sects
 151 |