{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Ivory.Language.Syntax.Concrete.QQ.AreaQQ
( fromArea
, fromAreaImport
) where
import Language.Haskell.TH hiding (Exp, Stmt,
Type)
import Ivory.Language.Syntax.Concrete.ParseAST
import Ivory.Language.Syntax.Concrete.QQ.Common
import Ivory.Language.Syntax.Concrete.QQ.ExprQQ
import Ivory.Language.Syntax.Concrete.QQ.TypeQQ
import qualified Ivory.Language.Init as I
import qualified Ivory.Language.MemArea as I
fromArea :: AreaDef -> Q [Dec]
fromArea a = do
(t, _) <- runToQ (fromType (areaType a))
let ty = AppT (ConT (if c then ''I.ConstMemArea else ''I.MemArea)) t
return [SigD (mkName nm) ty, d]
where
c = areaConst a
nm = allocRefVar (areaInit a)
d = ValD (VarP $ mkName nm) (NormalB imp) []
cntr = VarE (if c then 'I.constArea else 'I.area)
imp = AppE (AppE cntr (LitE (StringL nm))) ins
conIns z = if c then z else AppE (ConE 'Just) z
ins =
case areaInit a of
AllocBase _ mi
-> case mi of
Nothing -> if c then VarE 'I.izero else (ConE 'Nothing)
Just i -> conIns (AppE (VarE 'I.ival) (toExp [] i))
AllocArr _ i
-> case i of
[] -> if c then VarE 'I.izero else (ConE 'Nothing)
es -> let mkIval = AppE (VarE 'I.ival) in
let is = map (toExp []) es in
let lis = ListE (map mkIval is) in
conIns (AppE (VarE 'I.iarray) lis)
AllocStruct _ i
-> case i of
Empty
-> if c then AppE (VarE 'I.istruct) (ListE []) else (ConE 'Nothing)
MacroInit (fn,args)
-> let es = map (toExp []) args in
conIns (callit (mkVar fn) es)
FieldInits fieldAssigns
-> let es = map (toExp [] . snd) fieldAssigns in
let ls = ListE $ map assign (zip (fst $ unzip fieldAssigns) es) in
conIns (AppE (VarE 'I.istruct) ls)
where
assign (fnm, e) = InfixE (Just $ mkVar fnm) (VarE '(I..=)) (Just $ mkIval e)
mkIval = AppE (VarE 'I.ival)
fromAreaImport :: AreaImportDef -> Q [Dec]
fromAreaImport a = do
(t, _) <- runToQ (fromType (aiType a))
let ty = AppT (ConT (if c then ''I.ConstMemArea else ''I.MemArea)) t
return [SigD (mkName nm) ty, d]
where
c = aiConst a
nm = aiSym a
d = ValD (VarP $ mkName nm) (NormalB imp) []
cntr = VarE (if c then 'I.importConstArea else 'I.importArea)
imp = AppE (AppE cntr (LitE (StringL nm))) (LitE $ StringL (aiFile a))