cao-0.1.1: src/Language/CAO/Parser/Config.hs
{- CAO Compiler
Copyright (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. -}
{-
Module : $Header$
Description : Parsing of the platform configuration.
Copyright : (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
License : GPL
Maintainer : Paulo Silva <paufil@di.uminho.pt>
Stability : experimental
Portability : non-portable
-}
module Language.CAO.Parser.Config ( loadConfig ) where
import Control.Monad
import Data.Array
import Data.Char (isSpace, isAlphaNum, isNumber)
import Data.ConfigFile
import Data.Function (on)
import Data.List(foldl', sortBy)
import Data.Maybe (fromMaybe)
import Language.CAO.Platform.Literals
import Language.CAO.Platform.Specification
import Language.CAO.Platform.Naming
loadConfig :: String -> IO TranslationSpec
loadConfig confFile = do
readStr <- readfile emptyCP confFile
case readStr of
Left e -> configError $ show e
Right cf -> let
gpec = readGlobalSpec cf
spec = emptyTranslationSpec { globalTransSpec = gpec }
fpec = readType cf (defaultSafety gpec)
in return $ foldl' fpec spec (sections cf)
readGlobalSpec :: ConfigParser -> GlobalTransSpec
readGlobalSpec cff = GlobalTransSpec {
initProcName = readOptionDefault word' "initproc"
, disposeProcName = readOptionDefault word' "disposeproc"
, tpPrefix = readOptionDefault word' "typeprefix"
, callPrefix = readOptionDefault word' "callprefix"
, defaultHeader = readOptionDefault word' "header"
, defaultSafety = readOptionDefault parseSafety "safety"
, structFields = readOptionDefault parseFields "fields"
, wordSize = readOptionDefault parseWord "word"}
where
readOptionDefault p = run p . readOption cff "DEFAULT"
readType :: ConfigParser -> SafetyConv -> TranslationSpec -> SectionSpec -> TranslationSpec
readType cff safe tinfo sspec = updateTypes typinfo tinfo nrWords caotypes
where
typinfo = TypeSpec {
nameInPlat = sspec
, headerFile = readOptionS word' "header"
, code = readOptionS word' "code"
, declConv = readOptionS parseCall "declaration"
, memoryConv = readOptionS parseMemory "memory"
, funcCall = readOptionS parseFReturn "return"
, operands = readOptionS parseConsts "operands"
, literal = Nothing
, operations = array (0, 36) (auxOpers opers) }
nrWords = readOptionS parseSize "size"
caotypes = readOptionS parseType "type"
opcall = readOptionS parseOpCall "opcall"
opers = readOptionS (parseOperations opcall (operands typinfo) safe) "operations"
readOptionS p = run p . readOption cff sspec
-- Not very elegant solution
auxOpers = worker 0 . sortBy (compare `on` fst)
worker :: Int -> [(OpCode, (OpReturn, Consts, SafetyConv))] -> [(OpCode, Maybe (OpReturn, Consts, SafetyConv))]
worker 37 [] = []
worker 37 _ = error "Not expected configuration"
worker n [] = (n, Nothing) : worker (n+1) []
worker n l@((i, v):lst) = if n < i then (n, Nothing) : worker (n+1) l else (i, Just v) : worker (n+1) lst
updateTypes :: TypeSpec -> TranslationSpec -> Maybe (NumberOfWords, Maybe WordsPerChunk) -> [(String, Size)] -> TranslationSpec
updateTypes typinfo tspec nrWords = foldl' worker tspec
where
wordSz :: Maybe WordSize
wordSz = wordSize $ globalTransSpec tspec
worker :: TranslationSpec -> (String, Size) -> TranslationSpec
worker ti (typ, siz) = case typ of
"bool" -> tworker ti typ (\ ti' -> ti' { boolT = Just typinfo } ) boolT
"struct" -> tworker ti typ (\ ti' -> ti' { structT = Just typinfo } ) structT
"modpol" -> tworker ti typ (\ ti' -> ti' { modpolT = Just typinfo } ) modpolT
"int" -> tworker ti typ (\ ti' -> ti' { intT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) intT
"rint" -> tworker ti typ (\ ti' -> ti' { rintT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) rintT
"ubits" -> ti { typeTransSpec = (typeTransSpec ti) {
ubitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : ubitsT (typeTransSpec ti) } }
"sbits" -> ti { typeTransSpec = (typeTransSpec ti) {
sbitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : sbitsT (typeTransSpec ti) } }
"vector" -> ti { typeTransSpec = (typeTransSpec ti) {
vectorT = (siz, typinfo) : vectorT (typeTransSpec ti) } }
"matrix" -> ti { typeTransSpec = (typeTransSpec ti) {
matrixT = (siz, typinfo) : matrixT (typeTransSpec ti) } }
"mod" -> ti { typeTransSpec = (typeTransSpec ti) {
modT = (siz, typinfo { literal = checkMod wordSz siz nrWords }) : modT (typeTransSpec ti) } }
_ -> configError $ "Not known type identifier: " ++ typ
tworker :: TranslationSpec -> String -> (TypeTransSpec -> TypeTransSpec) -> (TypeTransSpec -> Maybe TypeSpec) -> TranslationSpec
tworker ti typ f1 sel = maybe
(ti {typeTransSpec = f1 (typeTransSpec ti) })
(configError $ "Configuration already found for type: " ++ typ)
(sel (typeTransSpec ti))
configError :: String -> a
configError err = error $
"[ERROR] There was an error in the configuration file:\n" ++ err
readOption :: ConfigParser -> SectionSpec -> OptionSpec -> String
readOption cff sspec opt =
either (configError . ("Option not found: " ++) . show) id
((get cff sspec opt)::Either CPError String)
--------------------------------------------------------------------------------
parseType :: ReadC [(String, Size)]
parseType = sepBy (comp (,) (word id) (option Generic (brackets tsize))) comma
parseCall :: ReadC VarDeclaration
parseCall
= keyword VarDecl "var"
<|> keyword MacroDecl "macro"
parseMemory :: ReadC VarMemory
parseMemory
= seqOpt (keyword Auto "auto")
(keyword AutoRef "ref")
Auto
<|> keyword Alloc "alloc"
parseFReturn :: ReadC FuncReturn
parseFReturn
= keyword FFuncReturn "val"
<|> keyword FFuncRef "ref"
parseOpCall :: ReadC OpReturn
parseOpCall
= seqOpt (keyword OMacroRef "macro")
(keyword OMacroReturn "val")
OMacroRef
<|> seqOpt (keyword OFuncRef "func")
(keyword OFuncReturn "val")
OFuncRef
parseSafety :: ReadC SafetyConv
parseSafety
= keyword Safe "safe"
<|> keyword Unsafe "unsafe"
<|> keyword ArgSafe "arg_safe"
parseConsts :: ReadC Consts
parseConsts
= keyword GlobalV "vars_global"
<|> keyword LocalV "vars_local"
<|> keyword Inlined "inlined"
<|> keyword Mixed "mixed"
parseFields :: ReadC FieldsConv
parseFields
= keyword GlobalF "global"
<|> keyword InlinedF "inlined"
parseWord :: ReadC (Maybe WordSize)
parseWord
= keyword Nothing "undefined"
<|> apply (Just . fromInteger) number
parseSize :: ReadC (Maybe (NumberOfWords, Maybe WordsPerChunk))
parseSize
= keyword Nothing "undefined"
<|> apply (Just . (\x -> (x, Nothing)) . fromInteger) number
<|> comp (\ _ (n1, n2) -> Just (fromInteger n1, Just $ fromInteger n2))
(keyword () "split")
(pair number number)
parseOperations :: OpReturn -> Consts -> SafetyConv -> ReadC [(OpCode, (OpReturn, Consts, SafetyConv))]
parseOperations defaultRet operand safe =
sepBy (comp (,) parseOperation
(option (defaultRet, operand, safe) (parens $
perm3 comma
parseOpCall
parseConsts
parseSafety
defaultRet operand safe))) comma
parseOperation :: ReadC OpCode
parseOperation = word aux
where
aux w = fromMaybe
(parseError $ "Not expected operation name: `" ++ w ++ "'") $ getCode w
--------------------------------------------------------------------------------
type ReadC a = String -> Either String (String, a)
parseError :: String -> a
parseError err = error $
"[ERROR] There was a parsing error while reading the configuration file:\n" ++
err
run :: ReadC a -> String -> a
run p str = case p str of
Left err -> parseError err
Right (str', v) ->
if null str'
then v
else parseError $ "Trailing string not expected: `" ++ str' ++
"' while reading `" ++ str ++ "'"
sepBy :: ReadC a -> ReadC sep -> ReadC [a]
sepBy p psep str = do
(str', v) <- p str
if null str' then return (str', [v])
else do
(str'', _) <- psep str'
(str''', lv) <- sepBy p psep str''
return (str''', v : lv)
comp :: (a -> b -> c) -> ReadC a -> ReadC b -> ReadC c
comp f p1 p2 str = do
(str1, v1) <- p1 str
(str2, v2) <- p2 str1
return (str2, f v1 v2)
inject :: a -> ReadC a
inject d = \ s -> return (s, d)
(<|>) :: ReadC a -> ReadC a -> ReadC a
(p1 <|> p2) str = p1 str `mplus` p2 str
option :: a -> ReadC a -> ReadC a
option a p str = p str `mplus` return (str, a)
comma :: ReadC ()
comma (',' : str) = white str
comma str = Left $ "Expected comma before `" ++ str ++ "'"
white :: ReadC ()
white str = return (dropWhile isSpace str, ())
delim :: Char -> Char -> ReadC a -> ReadC a
delim co cc p (co' : str) | co == co' = do
(str', _) <- white str
(str'', v) <- p str'
when (null str'' || head str'' /= cc) $ Left $
"Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "' around `" ++
str' ++ "'"
(str''', _) <- white (tail str'')
return (str''', v)
delim co cc _ _ = Left $ "Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "'"
parens :: ReadC a -> ReadC a
parens = delim '(' ')'
brackets :: ReadC a -> ReadC a
brackets = delim '[' ']'
number :: ReadC Integer
number str = do
let (n, str') = span isNumber str
when (null n) $ Left $ "Expected number in `" ++ str ++ "'"
(str'', _) <- white str'
return (str'', (read n::Integer))
keyword :: a -> String -> ReadC a
keyword val key str = do
(str', w) <- word id str
if key == w
then return (str', val)
else Left $
"Expected keyword `" ++ key ++ "'. Got `" ++ w ++ "' instead."
word :: (String -> b) -> ReadC b
word f str = do
let (w, str') = span (\ c -> isAlphaNum c || c == '.' || c == '_') str
(ww, _) <- white str'
return (ww, f w)
word' :: ReadC String
word' = word id
tsize :: ReadC Size
tsize str = do
(str', n1) <- option 0 number str
if n1 == 0
then return (str', Generic)
else if not (null str') && head str' == 'x'
then do
(str'', _) <- white (tail str')
(str''', n2) <- option 0 number str''
if n2 == 0
then Left "Invalid size (0)"
else return (str''', MSize n1 n2)
else return (str', Simple n1)
perm2 :: ReadC () -> ReadC a -> ReadC b -> a -> b -> ReadC (a, b)
perm2 sep p1 p2 d1 d2 =
comp (,) p1 (comp (curry snd) sep p2) <|>
comp (flip (,)) p2 (comp (curry snd) sep p1) <|>
comp (,) p1 (inject d2) <|>
comp (,) (inject d1) p2
perm3 :: ReadC () -> ReadC a -> ReadC b -> ReadC c -> a -> b -> c -> ReadC (a, b, c)
perm3 sep p1 p2 p3 d1 d2 d3 =
comp (\ x (y, z) -> (x, y, z)) p1 (comp (curry snd) sep (perm2 sep p2 p3 d2 d3)) <|>
comp (\ (y, z) x -> (x, y, z)) (perm2 sep p2 p3 d2 d3) (comp (curry snd) sep p1) <|>
comp (\ x (y, z) -> (x, y, z)) p1 (inject (d2, d3)) <|>
comp (\ x (y, z) -> (x, y, z)) (inject d1) (perm2 sep p2 p3 d2 d3)
seqOpt :: ReadC a -> ReadC b -> b -> ReadC b
seqOpt p1 p2 d1 = comp (\_ y -> y) p1 (option d1 (parens p2))
apply :: (a -> b) -> ReadC a -> ReadC b
apply f p str = do
(str', v) <- p str
return (str', f v)
pair :: ReadC a -> ReadC b -> ReadC (a, b)
pair p1 p2 = parens (\ str -> do
(str', v1) <- p1 str
(str'', _) <- comma str'
(str''', v2) <- p2 str''
return (str''', (v1, v2)))