module Data.Cursor.CLASE.Gen.Adapters(adapterGen) where
import Data.List
import Data.Maybe
import Data.Cursor.CLASE.Gen.Util
import Language.Haskell.TH
import Data.Cursor.CLASE.Gen.PrintM
import System.FilePath
import System.IO
import qualified Data.Map as Map
import Data.Map (Map)
adapterGen :: [String] -> Name -> [Name] -> String -> Q [Dec]
adapterGen moduleNames rootName acceptableNames gendLanguage = do
nameMap <- buildMap acceptableNames
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
printClasses rootName nameMap
printVisitCursor rootName
printInstanceHeader rootName acceptableNames
let contextCtrs = buildContextCtrs nameMap
printVisitStep rootName nameMap contextCtrs
printVisitPartial rootName acceptableNames contextCtrs
printCursor
runIO $ hFlush fileOut
runIO $ hClose fileOut
return []
printHeader :: String -> String -> String -> PrintM ()
printHeader modName rootModName rootLangModName = do
printLn . unlines $ [ "{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,"
, " UndecidableInstances, RankNTypes, GADTs, TypeFamilies #-}"
, "{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-}"
, "module " ++ modName ++ " where"
, "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Adapters) -}"
, ""
, "import " ++ rootModName
, "import " ++ rootLangModName
, "import Data.Cursor.CLASE.Language"
, "import Data.Cursor.CLASE.Bound"
, "import Data.Cursor.CLASE.Traversal"
]
printClasses :: Name -> Map Name DataType -> PrintM ()
printClasses rootName = mapM_ (uncurry printClass) . Map.toList
where
rootNameS = nameBase rootName
printClass :: Name -> DataType -> PrintM ()
printClass clNam (DataType _ ctrs) = do
printLn $ "class " ++ rootNameS ++ "TraversalAdapter" ++ clNamS ++ " t where"
mapM_ printCases ctrs
printLn ""
where
clNamS = nameBase clNam
printCases :: Constructor -> PrintM ()
printCases ctr = do
printLn $ " visit" ++ ctrNameS ++ " :: " ++ tipe
where
tipe = concat . intersperse " -> " $ clNamS :
(map (const "t") . filter isNavigable . ctrKids $ ctr) ++ ["t"]
ctrNameS = nameBase .ctrName $ ctr
printClass _ _ = error "printClass for wraps list not supported [yet]!"
printVisitCursor :: Name -> PrintM ()
printVisitCursor nam = do
printLn . unlines $
[ "class " ++ (nameBase nam) ++ "TraversalAdapterCursor t where"
, " visitCursor :: " ++ (nameBase nam) ++ " -> t -> t"
]
printInstanceHeader :: Name -> [Name] -> PrintM ()
printInstanceHeader rootName okNames = do
printLn $ "instance (" ++ preconds ++
"\n " ++ rootNameS ++ "TraversalAdapterCursor t," ++
"\n Bound " ++ rootNameS ++ " t) => Traversal " ++ rootNameS ++ " t where\n"
where
preconds = concat . intersperse "\n " .
map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t,") $ okNameS
rootNameS = nameBase rootName
okNameS = map nameBase okNames
printVisitStep :: Name -> Map Name DataType -> [ContextCtr] -> PrintM ()
printVisitStep rootName nameMap ctxCtrs = do
printLn . unlines $
[ " visitStep it recurse = case reify it of"
, " TW x -> visitStep' x it recurse"
, " where"
, " visitStep' :: (" ++ preconds ++ ") =>"
, " TypeRepI a -> a -> (forall b . Reify " ++ rootNameS ++ " b => Movement " ++ rootNameS ++ " Down a b -> t) -> t"
]
mapM_ (uncurry printVisitStepCase) (Map.toList nameMap)
printLn ""
where
preconds = concat . intersperse ",\n " .
map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") .
map nameBase .
Map.keys $ nameMap
rootNameS = nameBase rootName
printVisitStepCase :: Name -> DataType -> PrintM ()
printVisitStepCase tipe (DataType _ ctrs) = do
printLn $ " visitStep' " ++ tipeS ++ "T it recurse = case it of"
mapM_ printVisitStepCtrCase ctrs
where
tipeS = nameBase tipe
printVisitStepCtrCase (Ctr ctrName kids) = do
printLn $ " " ++ ctrNameS ++ " " ++ underscorePattern ++ " -> visit" ++ ctrNameS ++ " it " ++ recursePatterns
where
ctrNameS = nameBase ctrName
underscorePattern = unwords $ replicate (length kids) "_"
recursePatterns = unwords . map (\k -> "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (== ctrName) . ctxCtrCtrTo) $ ctxCtrs
printVisitStepCase _ _ = error "Can't prinit visitStep case for list dts yet"
printVisitPartial :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printVisitPartial rootName okNames ctxCtrs = do
printLn . unlines $
[ " visitPartial (CW ctx) = visitPartial' ctx"
, " where"
, " visitPartial' :: (" ++ preconds ++ ") =>"
, " ContextI a b -> b -> t -> (forall c . Reify " ++ rootNameS ++ " c => Movement " ++ rootNameS ++ " Down b c -> t) -> t"
, " visitPartial' ctx it hole recurse = case ctx of"
]
mapM_ printCtrCase ctxCtrs
printLn ""
where
rootNameS :: String
rootNameS = nameBase rootName
preconds :: String
preconds = concat . intersperse ",\n " .
map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") $ okNameS
okNameS = map nameBase okNames
printCtrCase :: ContextCtr -> PrintM ()
printCtrCase cc = do
printLn $ " " ++ (ctxCtrName cc) ++ " " ++ underscores ++ " -> visit" ++ (nameBase . ctxCtrCtrTo $ cc) ++ " it " ++ recursePatterns
where
underscores = unwords $ replicate (numCCArgs cc) "_"
recursePatterns = unwords . map (\k -> if k == cc
then "hole"
else "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (==(ctxCtrCtrTo cc) ) . ctxCtrCtrTo) $ ctxCtrs
printCursor :: PrintM ()
printCursor = printLn $ " cursor = visitCursor"