Permalink
Browse files

Parse context types out of actual Haskell records

  • Loading branch information...
1 parent b9a9293 commit 045a90a2e828859f6e4eabbb60dcbd0c896143f7 @singpolyma committed Aug 18, 2012
Showing with 109 additions and 70 deletions.
  1. +68 −0 ParseRecords.hs
  2. +41 −70 mustache2hs.hs
View
@@ -0,0 +1,68 @@
+module ParseRecords (extractRecords, MuType(..), Records, Record, Field) where
+
+import Data.List
+import Data.Maybe
+
+import Language.Haskell.Parser
+import Language.Haskell.Syntax
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+type Records = [(String, Record)]
+type Record = [Field]
+type Field = (Text, MuType)
+data MuType = MuList String | MuLambda | MuVariable deriving (Show, Eq)
+
+isDataDecl :: HsDecl -> Bool
+isDataDecl (HsDataDecl {}) = True
+isDataDecl _ = False
+
+isTypeDecl :: HsDecl -> Bool
+isTypeDecl (HsTypeDecl {}) = True
+isTypeDecl _ = False
+
+hsNameToString :: HsName -> String
+hsNameToString (HsIdent s) = s
+hsNameToString (HsSymbol s) = s
+
+extractTypeFromBangType :: HsBangType -> HsType
+extractTypeFromBangType (HsBangedTy t) = t
+extractTypeFromBangType (HsUnBangedTy t) = t
+
+hsTypeName :: [(String, HsType)] -> HsType -> String
+hsTypeName types (HsTyCon (UnQual s)) | isJust $ lookup (hsNameToString s) types =
+ hsTypeName types $ fromJust $ lookup (hsNameToString s) types
+hsTypeName _ (HsTyCon (UnQual s)) = hsNameToString s
+hsTypeName _ t = error ("Trying to get type name for: " ++ show t)
+
+hsTypeToMuType :: [(String, HsType)] -> HsType -> MuType
+hsTypeToMuType types (HsTyApp (HsTyCon (Special HsListCon)) t) = MuList (hsTypeName types t)
+hsTypeToMuType _ (HsTyFun {}) = MuLambda
+hsTypeToMuType types (HsTyCon (UnQual s)) | isJust $ lookup (hsNameToString s) types =
+ hsTypeToMuType types $ fromJust $ lookup (hsNameToString s) types
+hsTypeToMuType _ _ = MuVariable
+
+extractFromField :: [(String, HsType)] -> ([HsName], HsBangType) -> Field
+extractFromField types (name, t) =
+ (T.pack $ concatMap hsNameToString name, hsTypeToMuType types $ extractTypeFromBangType t)
+
+extractFromRecordConstructor :: [(String, HsType)] -> HsConDecl -> [Field]
+extractFromRecordConstructor types (HsRecDecl _ _ fields) = map (extractFromField types) fields
+extractFromRecordConstructor _ _ = []
+
+extractFromDataDecl :: [(String, HsType)] -> HsDecl -> (String, Record)
+extractFromDataDecl types (HsDataDecl _ _ typeName _ constructors _) =
+ (hsNameToString typeName, concatMap (extractFromRecordConstructor types) constructors)
+extractFromDataDecl _ _ = error "Programmer error, only call extractFromDataDecl with TypeDecl"
+
+extractFromTypeDecl :: HsDecl -> (String, HsType)
+extractFromTypeDecl (HsTypeDecl _ name _ t) = (hsNameToString name, t)
+extractFromTypeDecl _ = error "Programmer error, only call extractFromTypeDecl with TypeDecl"
+
+extractRecords :: String -> Records
+extractRecords moduleSrc =
+ map (extractFromDataDecl (map extractFromTypeDecl types)) datas
+ where
+ (types, datas) = partition (isTypeDecl) $ filter (\d -> isDataDecl d || isTypeDecl d) decls
+ ParseOk (HsModule _ _ _ _ decls) = parseModule moduleSrc
View
@@ -9,9 +9,6 @@ import Data.Char
import Data.List
import Control.Monad.Trans.State (get, modify, evalState, State)
-import Data.Map (Map)
-import qualified Data.Map as Map
-
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
@@ -25,9 +22,9 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as BS
-type MuTree = (MuTypeHeader, [Mustache])
-type MuTypeHeader = [(Text, MuType)]
-data MuType = MuList | MuLambda deriving (Show, Eq)
+import ParseRecords
+
+type MuTree = [Mustache]
data Mustache =
MuText Text |
@@ -43,24 +40,9 @@ isMuComment _ = False
parser :: Parser MuTree
parser = do
- th <- option [] (skipSpace *> typeheader)
body <- many1 (comment <|> sectionInv <|> section <|> tripleVar <|> ampVar <|> mustache (var True) <|> txt)
- return (th, filter (not . isMuComment) body)
+ return $ filter (not . isMuComment) body
where
- typeheader = mustache $ do
- _ <- char '!'
- _ <- char '#'
- many1 (skipSpace *> onetype) <* skipSpace
- onetype = do
- n <- name
- skipSpace
- _ <- char ':'
- _ <- char ':'
- skipSpace
- t <- typeList <|> typeLambda
- return (n, t)
- typeList = char '[' >> char ']' >> return MuList
- typeLambda = char '(' >> char '-' >> char '>' >> char ')' >> return MuLambda
comment = mustache $ do
_ <- char '!'
many $ do
@@ -98,7 +80,7 @@ mintercalate :: (Monoid a) => a -> [a] -> a
mintercalate xs xss = mconcat (intersperse xs xss)
originalMustache :: MuTree -> Builder
-originalMustache (_, tree) = mconcat $ map origOne tree
+originalMustache = mconcat . map origOne
where
origOne (MuText txt) = Builder.fromText txt
origOne (MuVar name True) = mconcat [
@@ -131,46 +113,35 @@ originalMustache (_, tree) = mconcat $ map origOne tree
]
origOne _ = mempty
-ctxVars :: MuTree -> [Text]
-ctxVars (types, tree) = nub $ concatMap oneVars tree
- where
- oneVars (MuVar name _) = [name]
- oneVars (MuSection name (stypes, stree))
- | isJust (lookup name types) = [name]
- | otherwise = name: ctxVars ((stypes ++ types), stree)
- oneVars (MuSectionInv name (stypes, stree)) =
- name : ctxVars ((stypes ++ types), stree)
- oneVars _ = []
-
-codeGenTree :: (Show a, Enum a) => Text -> Text -> MuTree -> State (a, Map Text [Text]) Builder
-codeGenTree fname name (types, tree) = do
- (code, helpers) <- (second concat . unzip) <$> mapM (codeGen types name) tree
- (_, recs) <- get
+codeGenTree :: (Show a, Enum a) => Text -> String -> Records -> MuTree -> State a Builder
+codeGenTree fname rname recs tree = do
+ let Just rec = lookup rname recs
+ (code, helpers) <- (second concat . unzip) <$> mapM (codeGen (rname,rec) recs) tree
return $ mconcat [
Builder.fromText fname,
Builder.fromString " escapeFunction ctx@(",
- pattern (Map.lookup name recs),
+ pattern rec,
Builder.fromString ") = mconcat [",
mintercalate comma code,
Builder.fromString "]\n",
if null helpers then mempty else Builder.fromString "\twhere\n\t",
mintercalate wsep helpers
]
where
- pattern (Just ctx) = mconcat [
- Builder.fromText name,
- Builder.fromString "Record {",
+ pattern rec = mconcat [
+ Builder.fromString rname,
+ Builder.fromString " {",
mintercalate comma $ map (\x -> mconcat [
Builder.fromText x,
Builder.fromString "=",
Builder.fromText x
- ]) ctx,
+ ]) (map fst rec),
Builder.fromString "}"
]
wsep = Builder.fromString "\n\t"
comma = Builder.fromString ", "
-codeGen :: (Show a, Enum a) => MuTypeHeader -> Text -> Mustache -> State (a, Map Text [Text]) (Builder, [Builder])
+codeGen :: (Show a, Enum a) => (String,Record) -> Records -> Mustache -> State a (Builder, [Builder])
codeGen _ _ (MuText txt) = return (Builder.fromShow (T.unpack txt), [])
codeGen _ _ (MuVar name False) = return (mconcat [
Builder.fromString "fromMaybe mempty ",
@@ -181,57 +152,57 @@ codeGen _ _ (MuVar name True) = return (mconcat [
Builder.fromText name,
Builder.fromString "))"
], [])
-codeGen types ctxName (MuSection name (stypes, stree))
- | lookup name types == Just MuLambda =
+codeGen (rname,rec) recs (MuSection name stree)
+ | lookup name rec == Just MuLambda =
return (mconcat [
Builder.fromText name,
Builder.fromString " (",
- Builder.fromShow $ BS.toString $ Builder.toByteString $ originalMustache (stypes, stree),
+ Builder.fromShow $ BS.toString $ Builder.toByteString $ originalMustache stree,
Builder.fromString " )"
], [])
| otherwise = do
- (id, recs) <- get
- modify (first succ)
+ id <- get
+ modify succ
let nm = name `mappend` T.pack (show id)
- case lookup name types of
- Just MuList -> do
- let rec = concat $ maybeToList (Map.lookup name recs)
- modify (second $ Map.insert name
- (nub $ ctxVars (stypes ++ types, stree) ++ rec))
- helper <- codeGenTree nm name (stypes ++ types, stree)
+ case lookup name rec of
+ Just (MuList rname) -> do
+ helper <- codeGenTree nm rname recs stree
return (mconcat [
Builder.fromString "map (",
Builder.fromText nm,
Builder.fromString " escapeFunction) ",
Builder.fromText name
], [helper])
_ -> do
- helper <- codeGenTree nm ctxName (stypes ++ types, stree)
+ helper <- codeGenTree nm rname recs stree
return (mconcat [
Builder.fromString "case ",
Builder.fromText name,
Builder.fromString " of { Just _ -> (",
Builder.fromText nm,
Builder.fromString " escapeFunction ctx); _ -> mempty }"
], [helper])
-codeGen types ctxName (MuSectionInv name (stypes, stree)) = do
- (id, _) <- get
- modify (first succ)
- let nm = name `mappend` T.pack (show id)
- helper <- codeGenTree nm ctxName (stypes ++ types, stree)
- return (mconcat [
- Builder.fromString "if foldr (\\_ _ -> False) True ",
- Builder.fromText name,
- Builder.fromString " then ",
- Builder.fromText nm,
- Builder.fromString " escapeFunction ctx else mempty"
- ], [helper])
+codeGen (rname,rec) recs (MuSectionInv name stree) = do
+ id <- get
+ modify succ
+ let nm = name `mappend` T.pack (show id)
+ helper <- codeGenTree nm rname recs stree
+ return (mconcat [
+ Builder.fromString "if foldr (\\_ _ -> False) True ",
+ Builder.fromText name,
+ Builder.fromString " then ",
+ Builder.fromText nm,
+ Builder.fromString " escapeFunction ctx else mempty"
+ ], [helper])
codeGen _ _ _ = return mempty
main :: IO ()
main = do
[input] <- getArgs
Right tree <- parseOnly parser <$> T.readFile input
- let name = T.pack $ takeBaseName input
- Builder.toByteStringIO BS.putStr $ evalState (codeGenTree name name tree) (0, Map.fromList [(name, ctxVars tree)])
+ let name = takeBaseName input
+ let fname = T.pack name
+ let rname = (toUpper $ head name) : tail (name ++ "Record")
+ recs <- extractRecords <$> readFile "Records.hs"
+ Builder.toByteStringIO BS.putStr $ evalState (codeGenTree fname rname recs tree) 0
putStrLn ""

0 comments on commit 045a90a

Please sign in to comment.