Commit c50feaff authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Merge remote-tracking branch 'origin/new-abstract-curry' into records

parents 8d279ceb d1b912fa
......@@ -147,7 +147,6 @@ data TargetType
| FlatCurry -- ^ FlatCurry
| ExtendedFlatCurry -- ^ Extended FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
deriving (Eq, Show)
-- |Warnings flags
......@@ -369,10 +368,6 @@ options =
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ AbstractCurry : optTargetTypes opts }))
"generate (type infered) AbstractCurry code"
, Option "" ["uacy"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ UntypedAbstractCurry : optTargetTypes opts }))
"generate untyped AbstractCurry code"
, Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
"use custom preprocessor"
......
......@@ -163,7 +163,6 @@ process opts idx m fn deps
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
]
......
......@@ -70,22 +70,20 @@ trTypeDecl (DataDecl _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs'])
trTypeDecl (TypeDecl _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])
<$> trLocalIdent t <*> getVisibility t
<*> mapM genTVarIndex vs <*> trTypeExpr ty
trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' cs' -> [CType t' v vs' cs'])
trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' nc' -> [CNewType t' v vs' nc'])
<$> trLocalIdent t <*> getVisibility t
<*> mapM genTVarIndex vs <*> mapM trNewConsDecl [nc]
<*> mapM genTVarIndex vs <*> trNewConsDecl nc
trTypeDecl _ = return []
trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl (ConstrDecl _ _ c tys) = CCons
<$> trLocalIdent c <*> return (length tys)
<*> getVisibility c <*> mapM trTypeExpr tys
<$> trLocalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $
ConstrDecl p vs op [ty1, ty2]
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl (NewConstrDecl _ _ nc ty) = CCons
<$> trLocalIdent nc <*> return 1
<*> getVisibility nc <*> mapM trTypeExpr [ty]
<$> trLocalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType q ts) = CTCons <$> trQual q
......@@ -117,36 +115,31 @@ trFuncDecl :: Decl -> GAC [CFuncDecl]
trFuncDecl (FunctionDecl _ f eqs) = (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trLocalIdent f <*> getArity f <*> getVisibility f
<*> (getType f >>= trTypeExpr)
<*> (CRules CFlex <$> mapM trEquation eqs)
<*> mapM trEquation eqs
trFuncDecl (ForeignDecl _ _ _ f _) = (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trLocalIdent f <*> getArity f <*> getVisibility f
<*> (getType f >>= trTypeExpr)
<*> return (CExternal (idName f))
<*> return []
trFuncDecl (ExternalDecl _ fs) = T.forM fs $ \f -> CFunc
<$> trLocalIdent f <*> getArity f <*> getVisibility f
<*> (getType f >>= trTypeExpr)
<*> return (CExternal (idName f))
<*> return []
trFuncDecl _ = return []
trEquation :: Equation -> GAC CRule
trEquation (Equation _ lhs rhs) = inNestedScope $
(\ps (es, ds) -> CRule ps es ds) <$> trLhs lhs <*> trRhs rhs
trEquation (Equation _ lhs rhs) = inNestedScope
$ CRule <$> trLhs lhs <*> trRhs rhs
trLhs :: Lhs -> GAC [CPattern]
trLhs = mapM trPat . snd . flatLhs
trRhs :: Rhs -> GAC ([(CExpr, CExpr)], [CLocalDecl])
trRhs :: Rhs -> GAC CRhs
trRhs (SimpleRhs _ e ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
g' <- trQual qSuccessFunId
e' <- trExpr e
ds' <- concat <$> mapM trLocalDecl ds
return ([(CSymbol g', e')], ds')
CSimpleRhs <$> trExpr e <*> (concat <$> mapM trLocalDecl ds)
trRhs (GuardedRhs gs ds) = inNestedScope $ do
mapM_ insertDeclLhs ds
gs' <- mapM trCondExpr gs
ds' <- concat <$> mapM trLocalDecl ds
return (gs', ds')
CGuardedRhs <$> mapM trCondExpr gs <*> (concat <$> mapM trLocalDecl ds)
trCondExpr :: CondExpr -> GAC (CExpr, CExpr)
trCondExpr (CondExpr _ g e) = (,) <$> trExpr g <*> trExpr e
......@@ -166,22 +159,14 @@ trLocalDecl :: Decl -> GAC [CLocalDecl]
trLocalDecl f@(FunctionDecl _ _ _) = map CLocalFunc <$> trFuncDecl f
trLocalDecl f@(ForeignDecl _ _ _ _ _) = map CLocalFunc <$> trFuncDecl f
trLocalDecl f@(ExternalDecl _ _) = map CLocalFunc <$> trFuncDecl f
trLocalDecl (PatternDecl _ p rhs) = (\p' (e',ds') -> [CLocalPat p' e' ds'])
<$> trPat p <*> trLocalPatRhs rhs
trLocalDecl (FreeDecl _ vs) = map CLocalVar <$> mapM getVarIndex vs
trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
<$> trPat p <*> trRhs rhs
trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs'])
<$> mapM getVarIndex vs
trLocalDecl _ = return [] -- can not occur (types etc.)
trLocalPatRhs :: Rhs -> GAC (CExpr, [CLocalDecl])
trLocalPatRhs (SimpleRhs _ e ds) = inNestedScope $ do
ds' <- concat <$> mapM trLocalDecl ds
e' <- trExpr e
return (e', ds')
trLocalPatRhs _ = unsupported $ "guarded expressions in pattern declarations"
trExpr :: Expression -> GAC CExpr
trExpr (Literal l) = case l of
String _ cs -> trExpr $ List [] $ map (Literal . Char noRef) cs -- TODO
_ -> return (CLit $ cvLiteral l)
trExpr (Literal l) = return (CLit $ cvLiteral l)
trExpr (Variable v)
| isQualified v = CSymbol <$> trQual v
| otherwise = lookupVarIndex v' >>= \mvi -> case mvi of
......@@ -190,7 +175,7 @@ trExpr (Variable v)
where v' = unqualify v
trExpr (Constructor c) = CSymbol <$> trQual c
trExpr (Paren e) = trExpr e
trExpr (Typed e _) = trExpr e -- TODO
trExpr (Typed e ty) = CTyped <$> trExpr e <*> trTypeExpr ty
trExpr (Tuple _ es) = trExpr $ case es of
[] -> Variable qUnitId
[x] -> x
......@@ -227,12 +212,17 @@ trExpr (Do ss e) = inNestedScope $
<$> mapM trStatement ss <*> trExpr e
trExpr (IfThenElse _ e1 e2 e3) = trExpr
$ apply (Variable qIfThenElseId) [e1,e2,e3]
trExpr (Case _ _ e bs) = CCase <$> trExpr e <*> mapM trAlt bs -- TODO
trExpr (Case _ ct e bs) = CCase (cvCaseType ct)
<$> trExpr e <*> mapM trAlt bs
trExpr (RecordConstr fs) = CRecConstr <$> mapM (trField trExpr) fs
trExpr (RecordSelection e l) = CRecSelect <$> trExpr e <*> return (idName l)
trExpr (RecordUpdate fs e) = CRecUpdate <$> mapM (trField trExpr) fs
<*> trExpr e
cvCaseType :: CaseType -> CCaseType
cvCaseType Flex = CFlex
cvCaseType Rigid = CRigid
apply :: Expression -> [Expression] -> Expression
apply = foldl Apply
......@@ -241,19 +231,11 @@ trStatement (StmtExpr _ e) = CSExpr <$> trExpr e
trStatement (StmtDecl ds) = CSLet <$> trLocalDecls ds
trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p
trAlt :: Alt -> GAC CBranchExpr
trAlt (Alt _ p rhs) = inNestedScope $ trBranch <$> trPat p <*> trRhs rhs
where
trBranch p' ([(g', e')], [])
| g' == CSymbol ("Prelude", "success") = CBranch p' e'
trBranch p' (gs', ds)
| null ds = CGuardedBranch p' gs'
| otherwise = unsupported "local declarations in case branches"
trAlt :: Alt -> GAC (CPattern, CRhs)
trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs
trPat :: Pattern -> GAC CPattern
trPat (LiteralPattern l) = case l of
String _ cs -> trPat $ ListPattern [] $ map (LiteralPattern . Char noRef) cs -- TODO
_ -> return (CPLit $ cvLiteral l)
trPat (LiteralPattern l) = return (CPLit $ cvLiteral l)
trPat (VariablePattern v) = CPVar <$> getVarIndex v
trPat (ConstructorPattern c ps) = CPComb <$> trQual c <*> mapM trPat ps
trPat (InfixPattern p1 op p2) = trPat $ ConstructorPattern op [p1, p2]
......@@ -266,7 +248,7 @@ trPat (ListPattern _ ps) = trPat $
foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2])
(ConstructorPattern qNilId [])
ps
trPat (NegativePattern _ _) = unsupported "negative patterns" -- TODO
trPat (NegativePattern _ l) = trPat $ LiteralPattern $ negateLiteral l
trPat (AsPattern v p) = CPAs <$> getVarIndex v<*> trPat p
trPat (LazyPattern _ p) = CPLazy <$> trPat p
trPat (FunctionPattern f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps
......@@ -277,11 +259,16 @@ trPat (RecordPattern fs mr) = CPRecord <$> mapM (trField trPat) fs
trField :: (a -> GAC b) -> Field a -> GAC (CField b)
trField act (Field _ l x) = (,) <$> return (idName l) <*> act x
negateLiteral :: Literal -> Literal
negateLiteral (Int v i) = Int v (-i)
negateLiteral (Float p' f) = Float p' (-f)
negateLiteral _ = internalError "GenAbstractCurry.negateLiteral"
cvLiteral :: Literal -> CLiteral
cvLiteral (Char _ c) = CCharc c
cvLiteral (Int _ i) = CIntc i
cvLiteral (Float _ f) = CFloatc f
cvLiteral _ = internalError "GenAbstractCurry.cvLiteral" -- TODO
cvLiteral (Char _ c) = CCharc c
cvLiteral (Int _ i) = CIntc i
cvLiteral (Float _ f) = CFloatc f
cvLiteral (String _ s) = CStringc s
trQual :: QualIdent -> GAC QName
trQual qid
......@@ -324,9 +311,6 @@ qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
qIfThenElseId :: QualIdent
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
qSuccessFunId :: QualIdent
qSuccessFunId = qualifyWith preludeMIdent (mkIdent "success")
-- Checks, whether a symbol is defined in the Prelude.
isPreludeSymbol :: QualIdent -> Bool
isPreludeSymbol qid
......@@ -460,6 +444,3 @@ getType f = do
getVisibility :: Ident -> GAC CVisibility
getVisibility i = S.gets $ \env -> if Set.member i (exports env) then Public
else Private
unsupported :: String -> a
unsupported feature = error $ "AbstractCurry does not support " ++ feature
......@@ -327,14 +327,11 @@ writeFlatIntf opts fn env modSum il
outputInterface = EF.writeFlatCurry (useSubDir targetFile) intf
writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
writeAbstractCurry opts fname env modul = do
when acyTarget $ AC.writeCurry (useSubDir $ acyName fname)
$ genAbstractCurry env modul
when uacyTarget $ AC.writeCurry (useSubDir $ uacyName fname)
$ genAbstractCurry env modul
writeAbstractCurry opts fn env mdl = do
when acyTarget $ AC.writeCurry (useSubDir $ acyName fn)
$ genAbstractCurry env mdl
where
acyTarget = AbstractCurry `elem` optTargetTypes opts
uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
type Dump = (DumpLevel, CompilerEnv, String)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment