Hi, I patched revision 79d67868840c so it builds with
haskell-src-exts-1.16.0.1 and ghc-7.8.3. I attached the patch.
Many of the fixes cause regressions so it's not ready for prime time yet.
I hope I used correct repo and didn't do work already done elsewhere.
To simplify reviewing the patch here are the relevant changes that
happened to hsx:
- One PatBind constructor argument was removed.
- Tuple, TupleCon and PTuple are now used for both boxed and unboxed
tuples so they have an extra argument,
- Hsx.UnknownDeclPragma was removed. I commented out a branch in
Convert.add_pragmas so adding pragmas is broken.
- BangType, BangedTy and UnBangedTy have changed.
- TyVarBind was introduced.
- InstDecl has 2 extra arguments
- PNeg was removed. Instead PLit has an extra argument to signify a
negated literal
- UnGuardedRhs is now used instead of UnGuardedAlt
- ListComp uses QualStmt instead of Stmt
- PBangPat was added
- EVar has an extra argument to signify namespace
--
Andrei
diff -r 79d67868840c Importer/Adapt.hs
--- a/Importer/Adapt.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Adapt.hs Sun Dec 21 15:15:28 2014 +0200
@@ -112,7 +112,7 @@
indexify :: [Hsx.Decl] -> [(String, Hsx.Exp)]
indexify decls = fold idxify decls [] where
- idxify (Hsx.PatBind _ (Hsx.PVar (Hsx.Ident name)) _ (Hsx.UnGuardedRhs rhs) _) xs =
+ idxify (Hsx.PatBind _ (Hsx.PVar (Hsx.Ident name)) (Hsx.UnGuardedRhs rhs) _) xs =
(name, rhs) : xs
idxify _ xs = xs
@@ -123,7 +123,7 @@
evaluateList eval (Hsx.List ts) = map eval ts
evaluatePair :: (Hsx.Exp -> a) -> (Hsx.Exp -> b) -> Hsx.Exp -> (a, b)
-evaluatePair eval1 eval2 (Hsx.Tuple [t1, t2]) = (eval1 t1, eval2 t2)
+evaluatePair eval1 eval2 (Hsx.Tuple Hsx.Boxed [t1, t2]) = (eval1 t1, eval2 t2)
evaluateEntryClass :: Hsx.Exp -> RawClassInfo
evaluateEntryClass (Hsx.Paren (Hsx.RecConstr (Hsx.UnQual (Hsx.Ident "RawClassInfo"))
diff -r 79d67868840c Importer/Convert.hs
--- a/Importer/Convert.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Convert.hs Sun Dec 21 15:15:28 2014 +0200
@@ -92,6 +92,7 @@
pragmas = [permissive_pragma]
add_pragmas :: Hsx.Decl -> [Pragma] -> [Pragma]
+{- FIXME add_pragmas
add_pragmas (Hsx.UnknownDeclPragma src "HASKABELLE" pragma) =
if null pragma then error ("empty pragma encountered at " ++ Hsx.srcloc2string src)
else let
@@ -99,6 +100,7 @@
in if directive `elem` pragmas
then AList.map_default (directive, []) (fold insert args)
else error ("unknown pragma " ++ directive ++ " encountered at " ++ Hsx.srcloc2string src)
+-}
add_pragmas _ = id
@@ -483,10 +485,14 @@
vs' = map (\(v, sort) -> (Ident_Env.toIsa v, Ident_Env.isa_of_sort sort)) e_vs
typ' = Ident_Env.toIsa e_typ
in Isa.TypeSign n' vs' typ'
-
+{- FIXME instance Convert
instance Convert Hsx.BangType Isa.Type where
convert' pragmas t@(Hsx.BangedTy _) = pattern_match_exhausted "Hsx.BangType -> Isa.Type" t
convert' pragmas (Hsx.UnBangedTy typ) = convert pragmas typ
+-}
+
+instance Convert Hsx.TyVarBind Isa.Name where
+ convert' = error "FIXME instance Convert Hsx.TyVarBind Isa.Name"
instance Convert Hsx.QOp Isa.Term where
convert' pragmas (Hsx.QVarOp qname) = do qname' <- convert pragmas qname; return (Isa.Const qname')
@@ -574,7 +580,7 @@
name_of (Hsx.Ident n) = n
name_of _ = ""
-convertDecl pragmas (Hsx.PatBind loc pattern _ rhs _wherebinds)
+convertDecl pragmas (Hsx.PatBind loc pattern rhs _wherebinds)
= case pattern of
pat@(Hsx.PVar name)
-> do name' <- convert pragmas name
@@ -609,7 +615,7 @@
typ' <- convert pragmas typ {-FIXME-}
return (map (\name' -> Isa.TypeSign name' [] typ') names')
-convertDecl pragmas (Hsx.InstDecl loc ctx cls [typ] stmts) = do
+convertDecl pragmas (Hsx.InstDecl loc _ _ ctx cls [typ] stmts) = do
cls' <- convert pragmas cls
typ' <- convert pragmas typ
case dest_typ_tvars typ' of
@@ -648,7 +654,7 @@
(_, typ) = Ident_Env.typschemeOf lexinfo
typ' = Ident_Env.substituteTyVars [(Ident_Env.TyVar tyvarN, tycon)] typ
in Ident_Env.Constant (Ident_Env.TypeAnnotation (lexinfo { Ident_Env.typschemeOf = ([], typ') }))
-convertDecl pragmas (Hsx.InstDecl loc ctx cls _ stmts) = dieWithLoc loc (Msg.only_one_tyvar_in_class_decl)
+convertDecl pragmas (Hsx.InstDecl loc _ _ ctx cls _ stmts) = dieWithLoc loc (Msg.only_one_tyvar_in_class_decl)
convertDecl pragmas junk = pattern_match_exhausted "Hsx.Decl -> Isa.Stmt" junk
@@ -693,7 +699,7 @@
convertPat pragmas (Hsx.PVar name) =
do name' <- liftConvert $ convert pragmas name
return (Isa.Const name')
-convertPat pragmas (Hsx.PLit lit) =
+convertPat pragmas (Hsx.PLit Hsx.Signless lit) =
do lit' <- liftConvert $ convert pragmas lit
return (Isa.Literal lit')
@@ -709,7 +715,7 @@
pats' <- mapM (convertPat pragmas) pats
return $ foldl Isa.App (Isa.Const qname') pats'
-convertPat pragmas (Hsx.PTuple comps) =
+convertPat pragmas (Hsx.PTuple Hsx.Boxed comps) =
convertPat pragmas (foldr Hsx.hskPPair (Hsx.PParen (last comps)) (init comps))
convertPat pragmas (Hsx.PList []) =
@@ -771,7 +777,7 @@
return (qname', exp')
instance Convert Hsx.Alt (Isa.Term, Isa.Term) where
- convert' pragmas (Hsx.Alt _loc pat (Hsx.UnGuardedAlt exp) _wherebinds)
+ convert' pragmas (Hsx.Alt _loc pat (Hsx.UnGuardedRhs exp) _wherebinds)
= do (pat',aliases) <- convert pragmas pat
exp' <- convert pragmas exp
let exp'' = mkSimpleLet aliases exp'
@@ -799,7 +805,7 @@
-- We have to wrap the last expression in an explicit HsParen as that last
-- expression may itself be a pair. If we didn't, we couldn't distinguish
-- between "((1,2), (3,4))" and "((1,2), 3, 4)" afterwards anymore.
- convert' pragmas (Hsx.Tuple exps) = convert pragmas (foldr Hsx.hsk_pair (Hsx.Paren (last exps)) (init exps))
+ convert' pragmas (Hsx.Tuple Hsx.Boxed exps) = convert pragmas (foldr Hsx.hsk_pair (Hsx.Paren (last exps)) (init exps))
convert' pragmas (Hsx.App exp1 exp2)
= do exp1' <- convert pragmas exp1
@@ -887,7 +893,7 @@
convert' pragmas expr@(Hsx.Let (Hsx.BDecls bindings) body)
= let (_, patbindings) = partition isTypeSig bindings
in assert (all isPatBinding patbindings)
- $ do let (pats, rhss) = unzip (map (\(Hsx.PatBind _ pat _ rhs _) -> (pat, rhs)) patbindings)
+ $ do let (pats, rhss) = unzip (map (\(Hsx.PatBind _ pat rhs _) -> (pat, rhs)) patbindings)
patsNames <- mapM (convert pragmas) pats
let (pats', aliases) = unzip patsNames
rhss' <- mapM (convert pragmas) rhss
@@ -896,9 +902,9 @@
return (Isa.Let (zip pats' rhss'') body')
where isTypeSig (Hsx.TypeSig _ _ _) = True
isTypeSig _ = False
- isPatBinding (Hsx.PatBind _ _ _ _ (Hsx.BDecls [])) = True
+ isPatBinding (Hsx.PatBind _ _ _ (Hsx.BDecls [])) = True
isPatBinding _ = False
-
+{- FIXME ListComp
convert' pragmas (Hsx.ListComp e stmts)
= do e' <- convert pragmas e
stmts' <- liftM concat $ mapM convertListCompStmt stmts
@@ -912,6 +918,7 @@
convertListCompStmt (Hsx.LetStmt _)
= die "Let statements not supported in List Comprehensions."
mkSimpleGens = map (\(n,t) -> Isa.Generator (Isa.Const n, mkList [t]))
+-}
convert' pragmas (Hsx.Do stmts)
= do isaStmts <- liftM concat $ mapM (convert pragmas) stmts
mbDo <- getCurrentMonadDoSyntax
@@ -932,7 +939,7 @@
convert' pragmas (Hsx.Qualifier exp) = liftM ( (:[]) . Isa.DoQualifier) (convert pragmas exp)
convert' pragmas (Hsx.LetStmt binds) =
case binds of
- Hsx.BDecls [Hsx.PatBind _ pat _ (Hsx.UnGuardedRhs exp) _] ->
+ Hsx.BDecls [Hsx.PatBind _ pat (Hsx.UnGuardedRhs exp) _] ->
do exp' <- convert pragmas exp
(pat', aliases) <- convert pragmas pat
aliases' <- mkDoLet pragmas aliases
@@ -971,9 +978,9 @@
do argNs <- mapM (liftGensym . Gensym.genHsQName) (replicate n (Hsx.UnQual (Hsx.Ident "arg")))
args <- return (map Hsx.Var argNs)
argNs' <- mapM (convert pragmas) argNs
- args' <- convert pragmas (Hsx.Tuple args)
+ args' <- convert pragmas (Hsx.Tuple Hsx.Boxed args)
return $ Isa.Parenthesized (makeAbs argNs' args')
- where pair x y = Hsx.App (Hsx.App (Hsx.Con (Hsx.Special (Hsx.TupleCon 2))) x) y
+ where pair x y = Hsx.App (Hsx.App (Hsx.Con (Hsx.Special (Hsx.TupleCon Hsx.Boxed 2))) x) y
{-|
HOL does not support pattern matching directly within a lambda
diff -r 79d67868840c Importer/DeclDependencyGraph.hs
--- a/Importer/DeclDependencyGraph.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/DeclDependencyGraph.hs Sun Dec 21 15:15:28 2014 +0200
@@ -75,7 +75,7 @@
isTypeAnnotation (Hsx.TypeSig _ _ _, _ , _) = True
isTypeAnnotation _ = False
- isInstance (Hsx.InstDecl _ _ _ _ _, _, _) = True
+ isInstance (Hsx.InstDecl _ _ _ _ _ _ _, _, _) = True
isInstance _ = False
isClass (Hsx.ClassDecl _ _ _ _ _ _, _, _) = True
isClass _ = False
diff -r 79d67868840c Importer/Hsx.hs
--- a/Importer/Hsx.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Hsx.hs Sun Dec 21 15:15:28 2014 +0200
@@ -118,14 +118,14 @@
the pair constructor @(,)@ to them.
-}
hskPPair :: Hsx.Pat -> Hsx.Pat -> Hsx.Pat
-hskPPair x y = Hsx.PApp (Hsx.Special (Hsx.TupleCon 2)) [x, y]
+hskPPair x y = Hsx.PApp (Hsx.Special (Hsx.TupleCon Hsx.Boxed 2)) [x, y]
{-|
The Haskell pair constructor. This function takes two Haskell expressions and applies
the pair constructor @(,)@ to them.
-}
hsk_pair :: Hsx.Exp -> Hsx.Exp -> Hsx.Exp
-hsk_pair x y = Hsx.App (Hsx.App (Hsx.Con (Hsx.Special (Hsx.TupleCon 2))) x) y
+hsk_pair x y = Hsx.App (Hsx.App (Hsx.Con (Hsx.Special (Hsx.TupleCon Hsx.Boxed 2))) x) y
{-|
The Haskell logical negation. This function takes a Haskell expression and applies
@@ -152,7 +152,7 @@
-}
hsk_case :: Hsx.SrcLoc -> Hsx.Exp -> [(Hsx.Pat, Hsx.Exp)] -> Hsx.Exp
hsk_case loc e cases
- = Hsx.Case e [ Hsx.Alt loc pat (Hsx.UnGuardedAlt exp) (Hsx.BDecls []) | (pat, exp) <- cases ]
+ = Hsx.Case e [ Hsx.Alt loc pat (Hsx.UnGuardedRhs exp) (Hsx.BDecls []) | (pat, exp) <- cases ]
{-|
This function turns a string into a Haskell name. Depending on the
@@ -230,13 +230,12 @@
namesFromDecl (Hsx.TypeDecl _ name _ _) = [Hsx.UnQual name]
namesFromDecl (Hsx.DataDecl _ _ _ name _ _ _) = [Hsx.UnQual name]
namesFromDecl (Hsx.ClassDecl _ _ name _ _ _) = [Hsx.UnQual name]
-namesFromDecl (Hsx.InstDecl _ _ qname _ _) = [qname]
+namesFromDecl (Hsx.InstDecl _ _ _ _ qname _ _) = [qname]
namesFromDecl (Hsx.TypeSig _ names _) = map Hsx.UnQual names
namesFromDecl (Hsx.InfixDecl _ _ _ ops) = [Hsx.UnQual n | n <- (universeBi ops :: [Hsx.Name])]
-namesFromDecl (Hsx.PatBind _ pat _ _ _) = bindingsFromPats [pat]
+namesFromDecl (Hsx.PatBind _ pat _ _) = bindingsFromPats [pat]
namesFromDecl (Hsx.FunBind (Hsx.Match _ fname _ _ _ _ : ms ))
= [Hsx.UnQual fname]
-namesFromDecl (Hsx.UnknownDeclPragma _ _ _) = []
namesFromDecl decl = error $ "Internal error: The given declaration " ++ show decl ++ " is not supported!"
{-|
@@ -334,16 +333,16 @@
fromExp (Hsx.MDo stmts)
= let bound = Set.fromList $ extractBindingNs stmts
in Env.Envs [bound]
- fromExp (Hsx.ListComp _ stmts)
- = let bound = Set.fromList $ extractBindingNs stmts
- in Env.Envs [bound, Set.empty]
+ fromExp (Hsx.ListComp _ stmts) = error "ListComp is not ported yet at boundNamesEnv"
+-- = let bound = Set.fromList $ extractBindingNs stmts
+-- in Env.Envs [bound, Set.empty]
fromExp exp = Env.uniEloc exp Set.empty
fromAlt :: Hsx.Alt -> HskNames
fromAlt (Hsx.Alt _ pat _ _) = Set.fromList $ extractBindingNs pat
fromDecl :: Hsx.Decl -> HskNames
- fromDecl (Hsx.PatBind _ _ _ _ whereBinds) = Set.fromList $
+ fromDecl (Hsx.PatBind _ _ _ whereBinds) = Set.fromList $
extractBindingNs whereBinds
fromDecl _ = Set.empty
@@ -550,8 +549,8 @@
renamePat renams pat
= case pat of
Hsx.PVar name -> Hsx.PVar (translate renams name)
- Hsx.PLit lit -> Hsx.PLit lit
- Hsx.PNeg pat -> Hsx.PNeg (renamePat renams pat)
+ Hsx.PLit sign lit -> Hsx.PLit sign lit
+ Hsx.PBangPat pat -> Hsx.PBangPat (renamePat renams pat)
Hsx.PInfixApp pat1 qname pat2 -> Hsx.PInfixApp pat1' qname' pat2'
where pat1' = renamePat renams pat1
qname' = qtranslate renams qname
@@ -559,7 +558,7 @@
Hsx.PApp qname pats -> Hsx.PApp qname' pats'
where qname' = qtranslate renams qname
pats' = map (renamePat renams) pats
- Hsx.PTuple pats -> Hsx.PTuple (map (renamePat renams) pats)
+ Hsx.PTuple boxed pats -> Hsx.PTuple boxed (map (renamePat renams) pats)
Hsx.PList pats -> Hsx.PList (map (renamePat renams) pats)
Hsx.PParen pat -> Hsx.PParen (renamePat renams pat)
Hsx.PWildCard -> Hsx.PWildCard
@@ -581,8 +580,8 @@
-> Hsx.TypeSig loc (map (translate renamings) names) typ
Hsx.FunBind matches
-> Hsx.FunBind (map renMatch matches)
- Hsx.PatBind loc pat some_typ rhs binds
- -> Hsx.PatBind loc (renamePat renamings pat) some_typ rhs binds
+ Hsx.PatBind loc pat rhs binds
+ -> Hsx.PatBind loc (renamePat renamings pat) rhs binds
_ -> decl
where renMatch :: Hsx.Match -> Hsx.Match
renMatch (Hsx.Match loc name pats some_typ rhs binds)
@@ -622,10 +621,7 @@
showModuleName (Hsx.ModuleName name) = name
-unBang :: Hsx.BangType -> Hsx.Type
-unBang (Hsx.UnBangedTy t) = t
-unBang (Hsx.BangedTy t) = t
+flattenRecFields :: [([Hsx.Name],Hsx.Type)] -> [(Hsx.Name,Hsx.Type)]
+flattenRecFields = concatMap flatten
+ where flatten (ns,bType) = map (\x -> (x,bType)) ns
-flattenRecFields :: [([Hsx.Name],Hsx.BangType)] -> [(Hsx.Name,Hsx.Type)]
-flattenRecFields = concatMap flatten
- where flatten (ns,bType) = zip ns (replicate (length ns) (unBang bType))
diff -r 79d67868840c Importer/Ident_Env.hs
--- a/Importer/Ident_Env.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Ident_Env.hs Sun Dec 21 15:15:28 2014 +0200
@@ -568,7 +568,8 @@
toHsk junk = error ("Type -> Hsx.Type: Fall Through: " ++ Msg.prettyShow' "thing" junk) -}
instance Hsk2Env Hsx.ExportSpec Export where
- fromHsk (Hsx.EVar qname) = ExportVar (fromHsk qname)
+ -- FIXME namespace
+ fromHsk (Hsx.EVar Hsx.NoNamespace qname) = ExportVar (fromHsk qname)
fromHsk (Hsx.EAbs qname) = ExportAbstr (fromHsk qname)
fromHsk (Hsx.EThingAll qname) = ExportAll (fromHsk qname)
fromHsk (Hsx.EModuleContents m) = ExportMod (fromHsk m)
@@ -582,6 +583,8 @@
(case nick of
Nothing -> Nothing
Just nick' -> Just $ fromHsk nick')
+instance Hsk2Env Hsx.TyVarBind Name where
+ fromHsk = error "FIXME TyVarBind"
{-|
Instances of this class are two types, on the one hand side Isabelle entities and on the other
@@ -665,14 +668,14 @@
primitive_tycon_table
= [(Hsx.ListCon, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident "ListTyCon")),
(Hsx.UnitCon, Hsx.Qual (Hsx.ModuleName "Prelude") unit_tyco),
- (Hsx.TupleCon 2, Hsx.Qual (Hsx.ModuleName "Prelude") pair_tyco)
+ (Hsx.TupleCon Hsx.Boxed 2, Hsx.Qual (Hsx.ModuleName "Prelude") pair_tyco)
]
primitive_datacon_table
= [(Hsx.Cons, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident ":")),
(Hsx.ListCon, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident "[]")),
(Hsx.UnitCon, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident "()")),
- (Hsx.TupleCon 2, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident "PairDataCon"))
+ (Hsx.TupleCon Hsx.Boxed 2, Hsx.Qual (Hsx.ModuleName "Prelude") (Hsx.Ident "PairDataCon"))
]
@@ -884,7 +887,7 @@
let moduleID = fromHsk modul
let defaultLexInfo = LexInfo { nameOf=nameID, typschemeOf=([], TyNone), moduleOf=moduleID}
case decl of
- Hsx.PatBind _ _ _ _ _ -> [Constant (Variable defaultLexInfo)]
+ Hsx.PatBind _ _ _ _ -> [Constant (Variable defaultLexInfo)]
Hsx.FunBind _ -> [Constant (Function defaultLexInfo)]
Hsx.InfixDecl _ a p _ -> [Constant (InfixOp defaultLexInfo (fromHsk a) p)]
Hsx.TypeSig _ _ typ -> [Constant (TypeAnnotation (defaultLexInfo { typschemeOf = typscheme_of_hsk_typ typ }))]
@@ -894,10 +897,11 @@
m = modul
methods = concatMap (computeConstantMappings m) typesigs
-- If length ns > 1, we will die later in Convert.hs anyway.
+
classInfo = makeClassInfo sups methods (fromHsk (head ns))
in [TypeDecl (Class defaultLexInfo classInfo)]
-- If length ts > 1, we will die later in Convert.hs anyway.
- Hsx.InstDecl _ _ _ ts _ -> [TypeDecl (Instance defaultLexInfo $ [makeInstanceInfo (fromHsk (head ts))])]
+ Hsx.InstDecl _ _ _ _ _ ts _ -> [TypeDecl (Instance defaultLexInfo $ [makeInstanceInfo (fromHsk (head ts))])]
Hsx.DataDecl _ _ _ conN tyvarNs condecls _
-> assert (fromHsk conN == nameID) $
let tycon = mkType (fromHsk name) tyvarNs
@@ -921,7 +925,7 @@
UnqualName name -> QualName moduleID name
mkDataCon :: Type -> Hsx.QualConDecl -> Constructor
mkDataCon tycon (Hsx.QualConDecl _ _ _ (Hsx.ConDecl n args))
- = let typ = foldr TyFun tycon (map (fromHsk . Hsx.unBang) args)
+ = let typ = foldr TyFun tycon (map fromHsk args)
in SimpleConstr conNe (makeLexInfo moduleID (fromHsk n) ([], typ))
mkDataCon tycon (Hsx.QualConDecl _ _ _ (Hsx.RecDecl name fields))
= let fields' = Hsx.flattenRecFields fields
diff -r 79d67868840c Importer/Preprocess.hs
--- a/Importer/Preprocess.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Preprocess.hs Sun Dec 21 15:15:28 2014 +0200
@@ -170,7 +170,7 @@
allBound = all (`elem` boundNames) closureNames
tuple = case closureNames of
[closureName] -> toPat closureName
- _ -> Hsx.PTuple (map toPat closureNames)
+ _ -> Hsx.PTuple Hsx.Boxed (map toPat closureNames)
passing = (Hsx.UnQual envName) `Set.member` Hsx.extractFreeVarNs match
envArg = if passing then if allBound
then Hsx.PVar envName
@@ -207,8 +207,8 @@
`Set.intersection` Hsx.extractFreeVarNs exp ))
boundNames = Set.fromList (Hsx.extractBindingNs pats)
shadowPatBind :: Hsx.Decl -> Hsx.Decl
- shadowPatBind (Hsx.PatBind loc pat some_typ rhs binds)
- = (Hsx.PatBind loc (shadow pat) some_typ rhs binds)
+ shadowPatBind (Hsx.PatBind loc pat rhs binds)
+ = (Hsx.PatBind loc (shadow pat) rhs binds)
shadowPVar :: Hsx.Pat -> Hsx.Pat
shadowPVar var@(Hsx.PVar name)
| Hsx.UnQual name `Set.member` boundNames = Hsx.PWildCard
@@ -240,17 +240,15 @@
addEnv (orig,ren) = (orig, Hsx.App (Hsx.Var ren) (Hsx.Var envName))
envTuple = case closureNameList of
[closureName] -> Hsx.Var closureName
- _ -> Hsx.Tuple (map Hsx.Var closureNameList)
+ _ -> Hsx.Tuple Hsx.Boxed (map Hsx.Var closureNameList)
addEnvTuple (orig,ren) = Hsx.PatBind
(Hsx.SrcLoc "" 0 0)
(Hsx.PVar $ uname orig)
- Nothing
(Hsx.UnGuardedRhs (Hsx.App (Hsx.Var ren) envTuple))
(Hsx.BDecls [])
withoutEnvTuple (orig,ren) = Hsx.PatBind
(Hsx.SrcLoc "" 0 0)
(Hsx.PVar $ uname orig)
- Nothing
(Hsx.UnGuardedRhs (Hsx.Var ren))
(Hsx.BDecls [])
subst = Map.fromList $ map addEnv renamings
@@ -285,7 +283,7 @@
This predicates checks whether the argument is a pattern binding.
-}
isPatBind :: Hsx.Decl -> Bool
-isPatBind (Hsx.PatBind _ _ _ _ _) = True
+isPatBind (Hsx.PatBind _ _ _ _) = True
isPatBind _ = False
@@ -304,7 +302,7 @@
typeSigs'
in (Hsx.BDecls (patTypeSigs ++ patDecls'), Hsx.BDecls (otherTypeSigs ++ otherDecls'))
- where split decl@(Hsx.PatBind _ _ _ _ _) = (Just decl, Nothing, Nothing)
+ where split decl@(Hsx.PatBind _ _ _ _) = (Just decl, Nothing, Nothing)
split decl@(Hsx.TypeSig _ _ _) = (Nothing, Just decl, Nothing)
split decl = (Nothing, Nothing, Just decl)
splitPatBinds junk = error ("splitPatBinds: Fall through. " ++ show junk)
@@ -370,13 +368,13 @@
isEmptyBinds _ = False
whereToLetDecl :: Hsx.Decl -> Hsx.Decl
-whereToLetDecl (Hsx.PatBind loc pat some_typ rhs binds)
+whereToLetDecl (Hsx.PatBind loc pat rhs binds)
| not $ isEmptyBinds binds =
case rhs of
Hsx.GuardedRhss _ -> assert False undefined
Hsx.UnGuardedRhs exp ->
let rhs' = Hsx.UnGuardedRhs $ Hsx.Let binds exp
- in Hsx.PatBind loc pat some_typ rhs' (Hsx.BDecls [])
+ in Hsx.PatBind loc pat rhs' (Hsx.BDecls [])
whereToLetDecl decl = decl
whereToLetMatch :: Hsx.Match -> Hsx.Match
@@ -394,9 +392,9 @@
| isEmptyBinds binds = orig
| otherwise =
case alt of
- Hsx.GuardedAlts _ -> assert False undefined
- Hsx.UnGuardedAlt exp ->
- let alt' = Hsx.UnGuardedAlt $ Hsx.Let binds exp
+ Hsx.GuardedRhss _ -> assert False undefined
+ Hsx.UnGuardedRhs exp ->
+ let alt' = Hsx.UnGuardedRhs $ Hsx.Let binds exp
in Hsx.Alt loc pat alt' (Hsx.BDecls [])
@@ -430,12 +428,12 @@
deguardifyRhs rhs@(Hsx.UnGuardedRhs _) = return rhs
deguardifyRhs (Hsx.GuardedRhss guards) = liftM Hsx.UnGuardedRhs $ deguardifyGuards guards
-deguardifyAlts :: Hsx.GuardedAlts -> DeguardifyEnv Hsx.GuardedAlts
-deguardifyAlts alt@(Hsx.UnGuardedAlt _) = return alt
-deguardifyAlts (Hsx.GuardedAlts guards) =
- liftM Hsx.UnGuardedAlt .
+deguardifyAlts :: Hsx.Rhs -> DeguardifyEnv Hsx.Rhs
+deguardifyAlts alt@(Hsx.UnGuardedRhs _) = return alt
+deguardifyAlts (Hsx.GuardedRhss guards) =
+ liftM Hsx.UnGuardedRhs .
deguardifyGuards .
- (map (\(Hsx.GuardedAlt l ss e) -> Hsx.GuardedRhs l ss e)) $
+ (map (\(Hsx.GuardedRhs l ss e) -> Hsx.GuardedRhs l ss e)) $
guards
deguardifyGuards :: [Hsx.GuardedRhs] -> DeguardifyEnv Hsx.Exp
deguardifyGuards guards =
diff -r 79d67868840c Importer/Printer.hs
--- a/Importer/Printer.hs Mon Aug 04 07:00:13 2014 +0200
+++ b/Importer/Printer.hs Sun Dec 21 15:15:28 2014 +0200
@@ -13,7 +13,7 @@
import qualified Text.PrettyPrint as P
-import qualified Language.Haskell.Exts as Hsx (SpecialCon(..), QName(..))
+import qualified Language.Haskell.Exts as Hsx (SpecialCon(..), QName(..), Boxed(..))
import Importer.Adapt as Adapt (AdaptionTable(AdaptionTable))
import qualified Importer.Ident_Env as Ident_Env
@@ -515,7 +515,7 @@
isNil adapt = mk_isFoo adapt Hsx.ListCon
isCons adapt = mk_isFoo adapt Hsx.Cons
-isPairCon adapt = mk_isFoo adapt (Hsx.TupleCon 2)
+isPairCon adapt = mk_isFoo adapt (Hsx.TupleCon Hsx.Boxed 2)
pprintAsList :: AdaptionTable -> [String] -> [Isa.Term] -> DocM P.Doc
pprintAsList adapt reserved ts = brackets (hsep (punctuate comma (map (pprint' adapt reserved) ts)))
diff -r 79d67868840c lib/Tools/haskabelle
--- a/lib/Tools/haskabelle Mon Aug 04 07:00:13 2014 +0200
+++ b/lib/Tools/haskabelle Sun Dec 21 15:15:28 2014 +0200
@@ -113,7 +113,7 @@
cd "$HASKABELLE_HOME"
mkdir -p "$BUILDDIR" || fail "Cannot create directory $BUILDDIR"
mkdir -p bin || fail "Cannot create directory bin"
- $ISABELLE_GHC -package haskell-src-exts-0.4.8 --make -O -o bin/haskabelle_bin \
+ $ISABELLE_GHC --make -O -o bin/haskabelle_bin \
-odir "$BUILDDIR" -hidir "$BUILDDIR" -stubdir "$BUILDDIR" "Main.hs"
) || fail "Cannot build source. See Haskabelle documentation."
elif [ ! -e "$HASKABELLE_BIN" ]; then
_______________________________________________
isabelle-dev mailing list
isabelle-...@in.tum.de
https://mailmanbroy.informatik.tu-muenchen.de/mailman/listinfo/isabelle-dev
