module DDC.Build.Interface.Load
( loadInterface
, Error (..)
, InterfaceAA)
where
import DDC.Build.Interface.Base
import DDC.Core.Check (AnTEC)
import DDC.Core.Module
import DDC.Base.Pretty
import DDC.Core.Transform.Reannotate
import Data.Time.Clock
import Control.Monad
import qualified DDC.Core.Load as Load
import qualified DDC.Core.Tetra as Tetra
import qualified DDC.Build.Language.Tetra as Tetra
import qualified DDC.Core.Salt as Salt
import qualified DDC.Build.Language.Salt as Salt
import qualified DDC.Data.SourcePos as BP
import qualified Data.Char as Char
import qualified Data.List as List
data Error
= ErrorEmpty
| ErrorNoMeta
| ErrorDuplicate
| ErrorBadMagic
{ errorFilePath :: FilePath
, errorLine :: Int }
| ErrorParse
{ errorFilePath :: FilePath
, errorLine :: Int}
| ErrorParseEnd
| ErrorLoadTetra (Load.Error Tetra.Name Tetra.Error)
| ErrorLoadSalt (Load.Error Salt.Name Salt.Error)
instance Pretty Error where
ppr ErrorEmpty
= vcat [ text "Empty interface file." ]
ppr ErrorNoMeta
= vcat [ text "No metadata section in interface file." ]
ppr ErrorDuplicate
= vcat [ text "Duplicate section in interface file." ]
ppr (ErrorBadMagic path l)
= vcat [ text path <> text ":" <> int l
, text "Bad header in interface file." ]
ppr (ErrorParse path l)
= vcat [ text path <> text ":" <> int l
, text "Parse error in interface file." ]
ppr ErrorParseEnd
= vcat [ text "Parse error at end of interface file." ]
ppr (ErrorLoadTetra err)
= vcat [ text "Error when loading Tetra module from interface file."
, indent 2 $ ppr err ]
ppr (ErrorLoadSalt err)
= vcat [ text "Error when loading Salt module from interface file."
, indent 2 $ ppr err ]
type LineNumber = Int
type Parser a
= [(LineNumber, String)]
-> Either Error a
type InterfaceAA
= Interface (AnTEC BP.SourcePos Tetra.Name) ()
loadInterface
:: FilePath
-> UTCTime
-> String
-> Either Error InterfaceAA
loadInterface pathInterface timeStamp str
= let
ls = lines str
lsNum = zip [1..] ls
in pInterface pathInterface timeStamp lsNum
pInterface
:: FilePath
-> UTCTime
-> Parser InterfaceAA
pInterface _pathInt _timeStamp []
= Left ErrorEmpty
pInterface pathInt timeStamp ((n, str) : rest)
| all (\c -> Char.isSpace c || c == '\n') str
= pInterface pathInt timeStamp rest
| ["ddc", "interface", version] <- words str
= do cs <- pComponents pathInt rest
modName <- case [m | m@ComponentMeta{} <- cs] of
[m] -> return $ componentModuleName m
_ -> Left $ ErrorNoMeta
mTetra <- case [m | m@ComponentTetraModule{} <- cs] of
[] -> return Nothing
[m] -> return $ Just $ componentTetraModule m
_ -> Left ErrorDuplicate
mSalt <- case [m | m@ComponentSaltModule{} <- cs] of
[] -> return Nothing
[m] -> return $ Just $ componentSaltModule m
_ -> Left ErrorDuplicate
return $ Interface
{ interfaceFilePath = pathInt
, interfaceTimeStamp = timeStamp
, interfaceVersion = version
, interfaceModuleName = modName
, interfaceTetraModule = mTetra
, interfaceSaltModule = liftM (reannotate (const ())) mSalt }
| otherwise
= Left $ ErrorBadMagic pathInt n
data Component
= ComponentMeta
{ componentModuleName :: ModuleName}
| ComponentTetraModule
{ componentTetraModule :: Module (AnTEC BP.SourcePos Tetra.Name) Tetra.Name }
| ComponentSaltModule
{ componentSaltModule :: Module (AnTEC BP.SourcePos Salt.Name) Salt.Name }
deriving Show
pComponents :: FilePath -> Parser [Component]
pComponents _ []
= return []
pComponents pathInterface (l : ls)
| all Char.isSpace (snd l)
= pComponents pathInterface ls
| isInterfaceTearLine (snd l)
= do let (ls', rest) = List.break (isInterfaceTearLine . snd) ls
c <- pComponent pathInterface (l : ls')
cs <- pComponents pathInterface rest
return $ c : cs
| otherwise
= Left $ ErrorParse pathInterface (fst l)
pComponent :: FilePath -> Parser Component
pComponent _ []
= Left $ ErrorParseEnd
pComponent pathInt ((n, l) : rest)
| all Char.isSpace l
= pComponent pathInt rest
| Just "Meta" <- takeInterfaceTearLine l
= pComponentMeta pathInt rest
| Just "Tetra" <- takeInterfaceTearLine l
= case Load.loadModuleFromString Tetra.fragment pathInt (n + 1)
Load.Recon (unlines $ map snd rest) of
(Left err, _) -> Left $ ErrorLoadTetra err
(Right m, _) -> return $ ComponentTetraModule m
| Just "Salt" <- takeInterfaceTearLine l
= case Load.loadModuleFromString Salt.fragment pathInt (n + 1)
Load.Recon (unlines $ map snd rest) of
(Left err, _) -> Left $ ErrorLoadSalt err
(Right m, _) -> return $ ComponentSaltModule m
| otherwise
= Left $ ErrorParse pathInt n
pComponentMeta :: FilePath -> Parser Component
pComponentMeta _pathInt []
= Left ErrorParseEnd
pComponentMeta pathInt nls@((n, _) : _)
| "module-meta" : "{" : "name:" : strModName : "}" : []
<- tokenize $ concatMap snd nls
, Just modName <- moduleNameOfString strModName
= return $ ComponentMeta
{ componentModuleName = modName }
| otherwise
= Left $ ErrorParse pathInt n
tokenize :: String -> [String]
tokenize str
= go [] str
where go acc [] = pop acc []
go acc (c : cs)
| Char.isSpace c = pop acc (go [] cs)
| c == '{' = pop acc ("{" : go [] cs)
| c == '}' = pop acc ("}" : go [] cs)
| otherwise = go (c : acc) cs
pop acc x
= case acc of
[] -> x
_ -> reverse acc : x
moduleNameOfString :: String -> Maybe ModuleName
moduleNameOfString str
= Just $ ModuleName $ go str
where
go s
| elem '.' s
, (n, '.' : rest) <- span (/= '.') s
= n : go rest
| otherwise
= [s]