{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Huff.QQ ( huff ) where import Huff.Compile as AST hiding (Name) import qualified Huff.Input as Input import Huff.QQ.Lexer (SourcePos(..)) import Huff.QQ.Parser (parseQQ) import Control.Monad (forM) import Data.Char (toLower) import Data.Function (on) import qualified Data.Text as T import qualified Data.Map.Strict as Map import Language.Haskell.TH import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote (QuasiQuoter(..)) huff :: QuasiQuoter huff = QuasiQuoter { quoteExp = notSupported "expressions" , quotePat = notSupported "patterns" , quoteType = notSupported "types" , quoteDec = huffDecs } where notSupported n _ = fail ("huff: Quasi-quotation is not supported for " ++ n) huffDecs :: String -> Q [Dec] huffDecs str = do loc <- location runIO (print loc) let (line,col) = loc_start loc let start = SourcePos { sourceIndex = 0 , sourceLine = line , sourceColumn = col } case parseQQ start str of Left err -> fail ("huff: " ++ show err) Right ds -> do dss <- mapM genDomain ds return (concat dss) -- | Translate the domain into one data declaration per `type`, as well as one -- big data declaration for the domain, with one constructor per operator. -- Additionally, write out an altered version of the domain, that will produce -- values of the new domain type. genDomain :: Domain T.Text -> Q [Dec] genDomain d@Domain { .. } = do let types = mkTypeMap domObjects objs <- mapM genObjectDecl (Map.toList types) dom <- genDomainDecl domName domOperators predss <- mapM genPredicate domPreds domValue <- genDomainValue d return (dom : domValue ++ objs ++ concat predss) mkTypeMap :: [Object] -> Map.Map T.Text [T.Text] mkTypeMap = foldl step Map.empty where step acc Typed { .. } = Map.alter (update tValue) tType acc update val Nothing = Just [val] update val (Just vs) = Just (val:vs) -- | Generate a data declaration from an object definition. -- -- INVARIANT: all objects are assumed to have the same type. genObjectDecl :: (T.Text,[T.Text]) -> Q Dec genObjectDecl (ty,objs) = do show <- [t| Show |] let cons = [ NormalC (mkName (T.unpack obj)) [] | obj <- objs ] return (DataD [] (mkName (T.unpack ty)) [] Nothing cons [show]) -- | Generate a specialized predicate that can produce either a literal, or a -- term. Produces one type-class per predicate, with instances for literals and -- terms. genPredicate :: AST.Pred -> Q [Dec] genPredicate (App f xs) = do let clsName = mkName ("Has_" ++ T.unpack f) var = mkName "a" pred = mkName (T.unpack f) arrow x = AppT (AppT ArrowT x) params = take (length xs) [ mkName ("x" ++ show x) | x <- [ 1 .. ] ] instLiteral <- [t| $(conT clsName) Literal |] instTerm <- [t| $(conT clsName) Term |] let mkArg p = [| AName (T.pack (show $(varE p))) |] litBody <- [| LAtom (App $(text f) $(listE (map mkArg params))) |] termBody <- [| TLit $(foldl appE (varE pred) (map varE params)) |] return [ ClassD [] clsName [PlainTV var] [] [ SigD pred (foldr arrow (VarT var) [ ConT (mkName (T.unpack x)) | x <- xs ]) ] , InstanceD Nothing [] instLiteral [ FunD pred [ Clause (map VarP params) (NormalB litBody) [] ] ] , InstanceD Nothing [] instTerm [ FunD pred [ Clause (map VarP params) (NormalB termBody) [] ] ] ] genDomainDecl :: T.Text -> [Operator T.Text] -> Q Dec genDomainDecl dom ops = do show <- [t| Show |] let tyName = mkName (T.unpack dom) cons <- mapM mkOpCon ops return (DataD [] tyName [] Nothing cons [show]) mkOpCon :: Operator T.Text -> Q Con mkOpCon op = do let conName = mkName (T.unpack (opName op)) fields <- forM (opParams op) $ \ Typed { .. } -> do let tyName = mkName (T.unpack tType) bangType (bang noSourceUnpackedness noSourceStrictness) (conT tyName) return (NormalC conName fields) genDomainValue :: Domain T.Text -> Q [Dec] genDomainValue Domain { .. } = do let n = mkDomVar (T.unpack domName) typesC = typeMap domObjects mkCon args name = let con x = ConE (mkName (T.unpack x)) in foldl AppE (con name) (map con args) opsC = compileOperators mkCon typesC domOperators body <- [d| $(varP n) = let types = $(liftTypes typesC) ops = $(listE (map liftOperator opsC)) in \ start goal -> if null goal then error "invalid goal specification" else compileProblem types ops (Problem start (foldr1 (/\) goal)) |] let domType = mkName (T.unpack domName) sigType <- [t| [AST.Literal] -> [AST.Term] -> Input.Spec $(conT domType) |] let sig = SigD n sigType return (sig:body) liftTypes :: TypeMap T.Text -> Q Exp liftTypes (TypeMap ts) = [| TypeMap (Map.fromList $(listE (map mkPair (Map.toList ts)))) |] where mkPair (k,xs) = [| ($(text k), $(listE (map text xs))) |] text :: T.Text -> Q Exp text str = [| T.pack $(lift (T.unpack str)) |] -- | Lift a grounded operator. liftOperator :: Operator Exp -> Q Exp liftOperator Operator { .. } = [| Operator { opName = $(text opName) , opDerived = $(lift opDerived) , opParams = [] , opVal = $(liftVal opVal) , opPrecond = $(liftTerm opPrecond) , opEffects = $(liftEffect opEffects) } |] where liftVal :: Maybe Exp -> Q Exp liftVal Nothing = [| Nothing |] liftVal (Just e) = [| Just $(return e) |] -- | Lift a precondition from a grounded operator. liftTerm :: Term -> Q Exp liftTerm (TAnd ts) = [| TAnd $(listE (map liftTerm ts)) |] liftTerm (TOr ts) = [| TOr $(listE (map liftTerm ts)) |] liftTerm (TLit lit) = [| TLit $(liftLit lit) |] liftTerm t = fail ("Compilation pass missed something: " ++ show t) liftLit :: Literal -> Q Exp liftLit (LAtom a) = [| LAtom $(liftAtom a) |] liftLit (LNot a) = [| LNot $(liftAtom a) |] liftAtom :: Atom -> Q Exp liftAtom (App f xs) = [| App $(text f) $(listE (map liftArg xs)) |] liftArg :: Arg -> Q Exp liftArg (AName n) = [| AName $(text n) |] liftArg (AVar n) = [| AVar $(text n) |] -- | Lift effects from a grounded operator. liftEffect :: Effect -> Q Exp liftEffect (EWhen p qs) = [| EWhen $(liftTerm p) $(listE (map liftLit qs)) |] liftEffect (EAnd es) = [| EAnd $(listE (map liftEffect es)) |] liftEffect (ELit lit) = [| ELit $(liftLit lit) |] liftEffect e = fail ("Compilation pass missed something: " ++ show e) mkDomVar :: String -> Name mkDomVar (h:tl) = mkName (toLower h : tl) mkDomVar [] = error "Invalid domain name: no name given"