module Yhc.Core.AnnotatePrims (
buildPrimSpecMap
,normPrimSpecMap
,CoreStrictness (..)
,CoreTypeSig (..)
,buildPrimAnno
,buildNormPrimAnno
) where
import Data.Maybe
import Yhc.Core
import Yhc.Core.PrimAnnoRaw
import Yhc.Core.Annotation
import qualified Data.Map as M
fparity (p@CorePrim {}) = corePrimArity p
fparity (f@CoreFunc {}) = length $ coreFuncArgs f
instance CoreAnnotable CoreFunc where
toAnnotationKey (p@CorePrim {}) = "primitive_" ++
coreFuncName p ++ "/" ++
show (corePrimArity p)
toAnnotationKey (f@CoreFunc {}) = "function_" ++
coreFuncName f ++ "/" ++
show (length $ coreFuncArgs f)
buildPrimSpecMap :: [[String]] -> M.Map String [String]
buildPrimSpecMap pspc = M.fromList $ map bpsm pspc where
bpsm (h:t) = (h, t)
normPrimSpecMap :: M.Map String [String]
normPrimSpecMap = buildPrimSpecMap rawPrimAnno
newtype CoreStrictness = CoreStrictness [Bool]
instance CoreProperty CoreStrictness where
toAnnString (CoreStrictness bsct) = map (\b -> if b then 'T' else 'F') bsct
fromAnnString s = mapM (\c -> case c of
'F' -> return False
'T' -> return True
_ -> fail $ "invalid strictness annotation: " ++ s) s
>>= return . CoreStrictness
newtype CoreTypeSig = CoreTypeSig String
instance CoreProperty CoreTypeSig where
toAnnString (CoreTypeSig s) = s
fromAnnString = return . CoreTypeSig
buildPrimAnno :: M.Map String [String] -> Core -> CoreAnnotations
buildPrimAnno mps core = ba M.empty (coreFuncs core) mps where
ba am [] _ = am
ba am (p:ps) mps | coreFuncName p `M.member` mps =
ba am'' ps mps where
bsct art "All" = replicate art True
bsct art "None" = replicate art False
bsct art s = take art $ map ('T' ==) s ++ repeat False
(use:descr:impl:arity:strct:tsig:_) = fromJust $ M.lookup (coreFuncName p) mps
am' = addAnnotation p ("Strictness", CoreStrictness (bsct (read arity) strct)) am
am'' = addAnnotation p ("Type", CoreTypeSig tsig) am'
ba am (_:ps) mps = ba am ps mps
buildNormPrimAnno :: Core -> CoreAnnotations
buildNormPrimAnno = buildPrimAnno normPrimSpecMap