module Data.Cursor.CLASE.Gen.Persistence(persistenceGen) where
import Language.Haskell.TH
import Data.Cursor.CLASE.Gen.Util
import Data.Cursor.CLASE.Gen.PrintM
import System.IO
import System.FilePath
import Data.List
import Data.Maybe
import Control.Monad
persistenceGen :: [String] -> Name -> [Name] -> String -> Q [Dec]
persistenceGen moduleNames rootName acceptableNames gendLanguage = do
nameMap <- buildMap acceptableNames
let contextCtrs = buildContextCtrs nameMap
fileOut <- runIO $ openFile (joinPath moduleNames <.> "hs") WriteMode
let rootNameModule = nameModule rootName
let moduleName = concat . intersperse "." $ moduleNames
runIO . runPrint fileOut $ do
printHeader moduleName (fromMaybe "" rootNameModule) gendLanguage
printClassHeader rootName
printShowMovement contextCtrs
printMovementUpDownLines
printShowTypeRep rootName acceptableNames
printTypeRepParser rootName acceptableNames
printTypeRepEq rootName acceptableNames
printUpMovesParser rootName acceptableNames contextCtrs
printDownMovesParser rootName acceptableNames contextCtrs
printFooter
runIO $ do
hFlush fileOut
hClose fileOut
return []
printHeader :: String -> String -> String -> PrintM ()
printHeader modName rootModName rootLangModName = do
printLn . unlines $
[ "{-# LANGUAGE TypeFamilies #-}"
, "{-# LANGUAGE GADTs #-}"
, "{-# LANGUAGE UndecidableInstances #-}"
, "{-# LANGUAGE FlexibleContexts #-}"
, "{-# LANGUAGE ScopedTypeVariables #-}"
, "{-# LANGUAGE RankNTypes #-}"
, "{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns #-}"
, "module " ++ modName ++ " where"
, "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Persistence) -}"
, ""
, "import " ++ rootModName
, "import " ++ rootLangModName
, "import Data.Cursor.CLASE.Language"
, "import Data.Cursor.CLASE.Persistence"
, "import qualified Text.ParserCombinators.Parsec.Language as P"
, "import qualified Text.ParserCombinators.Parsec.Token as P"
, "import Text.ParserCombinators.Parsec"
, "import Data.Cursor.CLASE.Util"
]
printClassHeader :: Name -> PrintM ()
printClassHeader rootName = do
printLn $ "instance (PersistenceAdapter " ++ rootNameS ++ ") => Persistable " ++ rootNameS ++ " where"
printLn ""
where
rootNameS = nameBase rootName
printShowMovement :: [ContextCtr] -> PrintM ()
printShowMovement ctxCtrs = do
printLns $
[ " showMovement (MW x) = show' x"
, " where"
, " show' :: MovementI dir from to -> String"
]
forM_ ctxCtrs printShowUpMovement
forM_ ctxCtrs printShowDownMovement
printLn ""
where
printShowUpMovement cc = printLn $
" show' (MUp " ++ smupctr ++ ") = \"" ++ mupctrshown ++ "\""
where
smupctr = downCtrName cc
mupctrshown = upCtrNameShown cc
printShowDownMovement cc = printLn $
" show' " ++ smupctr ++ " = \"" ++ smupctr ++ "\""
where
smupctr = downCtrName cc
printMovementUpDownLines :: PrintM ()
printMovementUpDownLines = do
printLns $
[ " movementParser UpT = upMovesParser"
, " movementParser DownT = downMovesParser"
, ""
]
printShowTypeRep :: Name -> [Name] -> PrintM ()
printShowTypeRep rootName acceptableNames = do
let rootNameS = nameBase rootName
printLns $
[ " showTypeRep = showTypeRep'"
, " where"
, " showTypeRep' :: forall a . TypeRep " ++ rootNameS ++ " a -> String"
]
forM_ acceptableNames $ \name -> do
let nameS = nameBase name
printLn $ " showTypeRep' (TW (" ++ nameS ++ "T :: TypeRepI a)) = \"" ++ nameS ++ "T\""
printLn ""
printTypeRepParser :: Name -> [Name] -> PrintM ()
printTypeRepParser rootName acceptableNames = do
printLns $
[ " typeRepParser = choice $ map (uncurry mkParser) itReps"
, " where"
, " itReps = [" ++ itRepLines ++ "]"
, ""
, " mkParser :: String -> Exists (TypeRep " ++ rootNameS ++ ") -> Parser (Exists (TypeRep " ++ rootNameS ++ "))"
, " mkParser s v = try $ (symbol s >> return v)"
, ""
]
where
rootNameS = nameBase rootName
itRepLines = concat . intersperse ",\n " $ itReps
itReps = map (\name -> let nameS = (nameBase name ++ "T") in
"(\"" ++ nameS ++ "\", (Exists (TW " ++ nameS ++ ")))")
acceptableNames
printTypeRepEq :: Name -> [Name] -> PrintM ()
printTypeRepEq rootName acceptableNames = do
printLns $
[ " typeRepEq = typeRepEq'"
, " where"
, " typeRepEq' :: forall a b . TypeRep " ++ rootNameS ++ " a -> TypeRep " ++ rootNameS ++ " b -> Maybe (TyEq a b)"
]
printLns reps
printLn " typeRepEq' _ _ = Nothing"
printLn ""
where
rootNameS = nameBase rootName
reps = map (\name -> let nameS = (nameBase name ++ "T") in
" typeRepEq' (TW (" ++ nameS ++ " :: TypeRepI a)) (TW (" ++
nameS ++ " :: TypeRepI b)) = Just Eq") $ acceptableNames
printUpMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printUpMovesParser rootName acceptableNames ctxctrs = do
printLns $
[ "upMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"
, "upMovesParser = upMovesParser' (reify (undefined :: a))"
, " where"
, " upMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "
, " Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"
, " upMovesParser' (TW x) = case x of"
]
printLns $ cases
printLn ""
printLns $
[ " use options = choice $ map (uncurry mkParser) options"
, " c :: forall a b . (Reify " ++ rootNameS ++ " b) => " ++
"MovementI Up a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a))"
, " c = return . ExistsR . MW"
, " mkParser p s = try (symbol s >> p)"
]
printLn ""
where
rootNameS = nameBase rootName
cases = concatMap mkOptions acceptableNames
mkOptions :: Name -> [String]
mkOptions name
| null options = [ " (" ++ nameS ++ " :: TypeRepI a) -> use []"]
| otherwise = [ " (" ++ nameS ++ " :: TypeRepI a) -> use options"
, " where"
, " options ="
, " [ " ++ optionLines
, " ]"
]
where
nameS = nameBase name ++ "T"
options = filter ((== name) . ctxCtrTypeFrom) ctxctrs
optionLines = concat . intersperse "\n , " . map mkOptionLine $ options
mkOptionLine ctxCtr = "(c $ (MUp " ++ dcs ++ "), \"" ++ ucs ++ "\")"
where
dcs = downCtrName ctxCtr
ucs = upCtrNameShown ctxCtr
printDownMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printDownMovesParser rootName acceptableNames ctxCtrs = do
printLns $
[ "downMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"
, "downMovesParser = downMovesParser' (reify (undefined :: a))"
," where"
," downMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "
," Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"
," downMovesParser' (TW x) = case x of"
]
printLns $ cases
printLn ""
printLns $
[ " use options = choice $ map (uncurry mkParser) options"
, " c :: forall a b . (Reify " ++ rootNameS ++ " b) => MovementI Down a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a))"
, " c = return . ExistsR . MW"
, " mkParser p s = try (symbol s >> p)"
]
printLn ""
where
rootNameS = nameBase rootName
cases = concatMap mkOptions acceptableNames
mkOptions :: Name -> [String]
mkOptions name
| null options = [ " (" ++ nameS ++ " :: TypeRepI a) -> use []"]
| otherwise = [ " (" ++ nameS ++ " :: TypeRepI a) -> use options"
, " where"
, " options ="
, " [ " ++ optionLines
, " ]"
]
where
nameS = nameBase name ++ "T"
options = filter ((== name) . ctxCtrTypeTo) ctxCtrs
optionLines = concat . intersperse "\n , " . map mkOptionLine $ options
mkOptionLine ctxCtr = "(c $ " ++ dcs ++ ", \"" ++ dcs ++ "\")"
where
dcs = downCtrName ctxCtr
printFooter :: PrintM ()
printFooter = printLns $
[ "haskellParser :: P.TokenParser st"
, "haskellParser = P.makeTokenParser P.haskellDef"
, ""
, "symbol :: String -> CharParser st String"
, "symbol = P.symbol haskellParser"
]