f (Left (Right x)) y z@(_, 42) = expr1:
f (Right a) "foo" y = expr2;
Patterns and Guards
Patterns and guards make programming much more pleasant.
Patty
We support definitions spread across multiple equations, and patterns in lambdas, case expressions, and the arguments of function definitions.
We leave supporting patterns as the left-hand side of an equation for another day. We also ignore fixity declarations for pattern infix operators.
Definitions with multiple equations
Consider a top-level function defined with multiple equations:
This is parsed as:
f = Pa [ ([(Left (Right x)), y, z@(_, 42)], expr1)
, ([(Right a) , "foo", y ], expr2)
]
where Pa is a data constructor for holding a collection of lists of patterns and their corresponding expressions.
We rewrite this as a lambda expression. Since there are 3 parameters, we generate 3 variable names and begin defining f as:
f = \1# 2# 3# -> ...
In our example, we start numbering the generated variable names from 1, but in general they start from the value of a carefully maintained counter.
We bind a join# variable that represents a join point which we later construct from the other defining equations.
f = \1# 2# 3# -> \join# -> ...
The first pattern of the first equation is (Left (Right x)), so we add:
f = \1# 2# 3# -> \join# -> case 1# of
{ Left 4# -> case 4# of
{ Left _ -> join#
; Right 5# -> ...
}
; Right _ -> join#
}
We encounter a variable x so we replace all free occurrences of x in expr1 with 5# which we denote expr1[5#/x].
The second pattern is y, so we replace all free occurrences of this variable in expr1 with 2# to get expr1[5#/x,2#/y].
For the third pattern, we start by replacing all free occurrences of z in with 3#. We have finished the first equation so we apply what we have so far to the expression we will obtain from rewriting the other definitions.
f = \1# 2# 3# -> (\join# -> case 1# of
{ Left 4# -> case 4# of
{ Left _ -> join#
; Right 5# -> case 3# of
{ (6#, 7#) -> if 7# == 42 then expr1[5#/x,2#/y,3#/z] else join#
}
}
; Right _ -> join#
}) $ ...
The first pattern of the second equation is Right a.
f = \1# 2# 3# -> (\join# -> case 1# of
{ Left 4# -> case 4# of
{ Left _ -> join#
; Right 5# -> case 3# of
{ (6#, 7#) -> if 7# == 42 then expr1[5#/x,2#/y,3#/z] else join#
}
}
; Right _ -> join#
}) $ \join# -> case 1# of
{ Left _ -> join#
; Right 8# -> ...
}
We replace all free occurrences of a in expr2 with 8#, which we denote expr2[8#/a].
Continuing in this fashion, by the end of the second equation we arrive at:
f = \1# 2# 3# -> (\join# -> case 1# of
{ Left 4# -> case 4# of
{ Left _ -> join#
; Right 5# -> case 3# of
{ (6#, 7#) -> if 7# == 42 then expr1[5#/x,2#/y,3#/z] else join#
}
}
; Right _ -> join#
}) $ (\join# -> case 1# of
{ Left _ -> join#
; Right 8# -> if 2# == "foo" then expr2[8#/a,3#/y] else join#
}) $ ...
As there are no more equations, we finish off with fail#, which causes program termination on execution:
f = \1# 2# 3# -> (\join# -> case 1# of
{ Left 4# -> case 4# of
{ Left _ -> join#
; Right 5# -> case 3# of
{ (6#, 7#) -> if 7# == 42 then expr1[5#/x,2#/y,3#/z] else join#
}
}
; Right _ -> join#
}) $ (\join# -> case 1# of
{ Left _ -> join#
; Right 8# -> if 2# == "foo" then expr2[8#/a,3#/y] else join#
}) $ fail#
Case expressions
We could apply the above to rewrite case expressions, but then we’d lose efficiency from performing a series of binary decisions instead of a single multi-way decision.
Instead, suppose we have:
case scrutinee of
Foo (Left 42) -> expr1
Baz -> expr2
Foo (Right a) -> expr3
Bar x "bar" -> expr4
z -> expr5
w -> expr6
Baz -> expr7
Bar x y -> expr8
x -> expr9
Conceptually, we combine contiguous data constructor alternatives into maps, where the keys are the data constructors, and the values are the corresponding expressions appended in the order they appear.
[ (Foo, [(Left 42) -> expr1, (Right a) -> expr3])
, (Bar, [x "bar" -> expr4])
, (Baz, [ -> expr2])
]
z -> expr5
w -> expr6
[ (Bar, [x y -> expr8])
, (Baz, [ -> expr7])
]
x -> expr9
We rewrite this to:
(\v -> (\cjoin# -> case v of
Foo 1# -> Pa [(Left 42) -> expr1, (Right a) -> expr3]
Bar -> Pa [x "bar" -> expr4]
Baz -> Pa [ -> expr2]
) $ (\pjoin# -> expr5[v/z]
) $ (\pjoin# -> expr6[v/z]
) $ (\cjoin# -> case v of
Foo _ -> cjoin#
Bar -> [x y -> expr8]
Baz -> Pa [ -> expr7]
) $ (V "fail#")
) scrutinee
We then apply the first rewrite algorithm to get:
(\v -> (\cjoin# -> case v of
Foo 1# -> case 1# of
Left 2# -> if 2# == 42 then expr1 else cjoin#
Right 3# -> expr3[3#/a]
Bar 4# 5# -> if 5# == "bar" then expr 4 else cjoin#
Baz -> expr2
) $ (\pjoin# -> expr5[v/z]
) $ (\pjoin# -> expr6[v/z]
) $ (\cjoin# -> case v of
Foo 8# -> cjoin#
Bar 9# 10# -> expr8[9#/x 10#/y]
Baz -> expr7
) $ (V "fail#")
) scrutinee
Our pattern rewriting algorithm sets pjoin# to fail#, that is, if none of the given patterns match, then the program exits. Our case rewriting algorithm subverts this by inserting a catch-all case that calls cjoin# before calling the pattern rewriting algorithm, so that instead of exiting, we examine the next batch of case patterns. We can probably refactor so that only one type of join point is needed, but for now we press on.
We try to avoid dead code with the optiApp helper which beta-reduces applications of lambdas where the bound variable appears at most once in the body, but this is imperfect because of the Pa value that may appear during Ca rewrites: we look for the bound variable before rewriting the Pa value, thus our count is wrong if the variable is later eliminated when rewriting the Pa value.
-- Patterns. infixr 9 .; infixl 7 * , / , %; infixl 6 + , -; infixr 5 ++; infixl 4 <*> , <$> , <* , *>; infix 4 == , /= , <=; infixl 3 && , <|>; infixl 2 ||; infixl 1 >> , >>=; infixr 0 $; ffi "putchar" putChar :: Int -> IO Int; ffi "getchar" getChar :: IO Int; data Bool = True | False; ife a b c = case a of { True -> b ; False -> c }; class Functor f where { fmap :: (a -> b) -> f a -> f b }; class Applicative f where { pure :: a -> f a ; (<*>) :: f (a -> b) -> f a -> f b }; class Monad m where { return :: a -> m a ; (>>=) :: m a -> (a -> m b) -> m b }; (>>) f g = f >>= \_ -> g; class Eq a where { (==) :: a -> a -> Bool }; instance Eq Int where { (==) = intEq }; ($) f x = f x; id x = x; const x y = x; flip f x y = f y x; (&) x f = f x; class Ord a where { (<=) :: a -> a -> Bool }; instance Ord Int where { (<=) = intLE }; data Ordering = LT | GT | EQ; compare x y = case x <= y of { True -> case y <= x of { True -> EQ ; False -> LT } ; False -> GT }; instance Ord a => Ord [a] where { (<=) xs ys = case xs of { [] -> True ; (:) x xt -> case ys of { [] -> False ; (:) y yt -> case compare x y of { LT -> True ; GT -> False ; EQ -> xt <= yt } } } }; data Maybe a = Nothing | Just a; data Either a b = Left a | Right b; fpair p = \f -> case p of { (,) x y -> f x y }; fst p = case p of { (,) x y -> x }; snd p = case p of { (,) x y -> y }; uncurry f p = fpair p \x y -> f x y; first f p = fpair p \x y -> (f x, y); second f p = fpair p \x y -> (x, f y); not a = case a of { True -> False; False -> True }; (.) f g x = f (g x); (||) f g = ife f True g; (&&) f g = ife f g False; flst xs n c = case xs of { [] -> n; (:) h t -> c h t }; instance Eq a => Eq [a] where { (==) xs ys = case xs of { [] -> case ys of { [] -> True ; (:) _ _ -> False } ; (:) x xt -> case ys of { [] -> False ; (:) y yt -> x == y && xt == yt } }}; take n xs = ife (n == 0) [] $ flst xs [] $ \h t -> h:take (n - 1) t; maybe n j m = case m of { Nothing -> n; Just x -> j x }; instance Functor Maybe where { fmap f = maybe Nothing (Just . f) }; foldr c n l = flst l n (\h t -> c h(foldr c n t)); length = foldr (\_ n -> n + 1) 0; mapM_ f = foldr ((>>) . f) (pure ()); instance Applicative IO where { pure = ioPure ; (<*>) f x = ioBind f \g -> ioBind x \y -> ioPure (g y) }; instance Monad IO where { return = ioPure ; (>>=) = ioBind }; instance Functor IO where { fmap f x = ioPure f <*> x }; putStr = mapM_ $ putChar . ord; error s = unsafePerformIO $ putStr s >> putChar (ord '\n') >> exitSuccess; undefined = error "undefined"; foldr1 c l = maybe undefined id (flst l undefined (\h t -> foldr (\x m -> Just (case m of { Nothing -> x ; Just y -> c x y })) Nothing l)); foldl f a bs = foldr (\b g x -> g (f x b)) (\x -> x) bs a; foldl1 f bs = flst bs undefined (\h t -> foldl f h t); elem k xs = foldr (\x t -> ife (x == k) True t) False xs; find f xs = foldr (\x t -> ife (f x) (Just x) t) Nothing xs; (++) = flip (foldr (:)); concat = foldr (++) []; wrap c = c:[]; map = flip (foldr . ((:) .)) []; instance Functor [] where { fmap = map }; concatMap = (concat .) . map; fmaybe m n j = case m of { Nothing -> n; Just x -> j x }; lookup s = foldr (\h t -> fpair h (\k v -> ife (s == k) (Just v) t)) Nothing; all f = foldr (&&) True . map f; any f = foldr (||) False . map f; upFrom n = n : upFrom (n + 1); zipWith f xs ys = flst xs [] $ \x xt -> flst ys [] $ \y yt -> f x y : zipWith f xt yt; zip = zipWith (,); -- Map. data Map k a = Tip | Bin Int k a (Map k a) (Map k a); size m = case m of { Tip -> 0 ; Bin sz _ _ _ _ -> sz }; node k x l r = Bin (1 + size l + size r) k x l r; singleton k x = Bin 1 k x Tip Tip; singleL k x l r = case r of { Tip -> undefined ; Bin _ rk rkx rl rr -> node rk rkx (node k x l rl) rr }; singleR k x l r = case l of { Tip -> undefined ; Bin _ lk lkx ll lr -> node lk lkx ll (node k x lr r) }; doubleL k x l r = case r of { Tip -> undefined ; Bin _ rk rkx rl rr -> case rl of { Tip -> undefined ; Bin _ rlk rlkx rll rlr -> node rlk rlkx (node k x l rll) (node rk rkx rlr rr) } }; doubleR k x l r = case l of { Tip -> undefined ; Bin _ lk lkx ll lr -> case lr of { Tip -> undefined ; Bin _ lrk lrkx lrl lrr -> node lrk lrkx (node lk lkx ll lrl) (node k x lrr r) } }; balance k x l r = case size l + size r <= 1 of { True -> node ; False -> case 5 * size l + 3 <= 2 * size r of { True -> case r of { Tip -> node ; Bin sz _ _ rl rr -> case 2 * size rl + 1 <= 3 * size rr of { True -> singleL ; False -> doubleL } } ; False -> case 5 * size r + 3 <= 2 * size l of { True -> case l of { Tip -> node ; Bin sz _ _ ll lr -> case 2 * size lr + 1 <= 3 * size ll of { True -> singleR ; False -> doubleR } } ; False -> node } } } k x l r; insert kx x t = case t of { Tip -> singleton kx x ; Bin sz ky y l r -> case compare kx ky of { LT -> balance ky y (insert kx x l) r ; GT -> balance ky y l (insert kx x r) ; EQ -> Bin sz kx x l r } }; insertWith f kx x t = case t of { Tip -> singleton kx x ; Bin sy ky y l r -> case compare kx ky of { LT -> balance ky y (insertWith f kx x l) r ; GT -> balance ky y l (insertWith f kx x r) ; EQ -> Bin sy kx (f x y) l r } }; mlookup kx t = case t of { Tip -> Nothing ; Bin _ ky y l r -> case compare kx ky of { LT -> mlookup kx l ; GT -> mlookup kx r ; EQ -> Just y } }; fromList = let { ins t kx = case kx of { (,) k x -> insert k x t } } in foldl ins Tip; foldrWithKey f = let { go z t = case t of { Tip -> z ; Bin _ kx x l r -> go (f kx x (go z r)) l } } in go; toAscList = foldrWithKey (\k x xs -> (k,x):xs) []; -- Parsing. data Type = TC String | TV String | TAp Type Type; arr a b = TAp (TAp (TC "->") a) b; data Extra = Basic Int | Const Int | StrCon String | Proof Pred; data Pat = PatPred Ast | PatVar String (Maybe Pat) | PatCon String [Pat]; data Ast = E Extra | V String | A Ast Ast | L String Ast | Pa [([Pat], Ast)] | Ca Ast [(Pat, Ast)]; ro = E . Basic . ord; data Parser a = Parser (String -> Maybe (a, String)); data Constr = Constr String [Type]; data Pred = Pred String Type; data Qual = Qual [Pred] Type; noQual = Qual []; data Neat = Neat -- | Instance environment. [(String, [Qual])] -- | Either top-level or instance definitions. [Either (String, Ast) (String, (Qual, [(String, Ast)]))] -- | Typed ASTs, ready for compilation, including ADTs and methods, -- e.g. (==), (Eq a => a -> a -> Bool, select-==) [(String, (Qual, Ast))] -- | Data constructor table. [(String, [Constr])] -- | FFI declarations. [(String, Type)] -- | Exports. [(String, String)] ; parse p inp = case p of { Parser f -> f inp }; fneat neat z = case neat of { Neat a b c d e f -> z a b c d e f }; conOf con = case con of { Constr s _ -> s }; specialCase = concatMap (('|':) . conOf); mkCase t cs = (specialCase cs, ( noQual $ arr t $ foldr arr (TV "case") $ map (\c -> case c of { Constr _ ts -> foldr arr (TV "case") ts}) cs , ro 'I')); mkStrs = snd . foldl (\p u -> fpair p (\s l -> ('@':s, s : l))) ("@", []); scottEncode vs s ts = foldr L (foldl (\a b -> A a (V b)) (V s) ts) (ts ++ vs); scottConstr t cs c = case c of { Constr s ts -> (s, ( noQual $ foldr arr t ts , scottEncode (map conOf cs) s $ mkStrs ts)) }; mkAdtDefs t cs = mkCase t cs : map (scottConstr t cs) cs; adtLookups cs = map (\c -> case c of { Constr s _ -> (s, cs) }) cs; select f xs acc = flst xs (Nothing, acc) \x xt -> ife (f x) (Just x, xt ++ acc) (select f xt (x:acc)); addInstance s q is = fpair (select (\kv -> s == fst kv) is []) \m xs -> case m of { Nothing -> (s, [q]):xs ; Just sqs -> second (q:) sqs:xs }; mkSel ms s = L "@" $ A (V "@") $ foldr L (V $ '*':s) $ map (('*':) . fst) ms; ifz n = ife (0 == n); showInt' n = ifz n id ((showInt' (n/10)) . ((:) (chr (48+(n%10))))); showInt n = ifz n ('0':) (showInt' n); mkFFIHelper n t acc = case t of { TC s -> acc ; TV s -> undefined ; TAp g y -> case g of { TC s -> ife (s == "IO") acc undefined ; TV s -> undefined ; TAp f x -> case f of { TC s -> ife (s == "->") (L (showInt n "") $ mkFFIHelper (n + 1) y $ A (V $ showInt n "") acc) undefined ; TV s -> undefined ; TAp _ _ -> undefined } } }; addAdt t cs acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs (mkAdtDefs t cs ++ typed) (adtLookups cs ++ dcs) ffis exs; addClass classId v ms acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs (map (\st -> fpair st \s t -> (s, (Qual [Pred classId v] t, mkSel ms s))) ms ++ typed) dcs ffis exs; addInst cl q ds acc = fneat acc \ienv fs typed dcs ffis exs -> Neat (addInstance cl q ienv) (Right (cl, (q, ds)):fs) typed dcs ffis exs; addFFI foreignname ourname t acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs ((ourname, (Qual [] t, mkFFIHelper 0 t $ A (ro 'F') (ro $ chr $ length ffis))) : typed) dcs ((foreignname, t):ffis) exs; addDefs ds acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv (map Left ds ++ fs) typed dcs ffis exs; addExport e f acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs typed dcs ffis ((e, f):exs); instance Applicative Parser where { pure x = Parser \inp -> Just (x, inp) ; (<*>) x y = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just funt -> fpair funt \fun t -> case parse y t of { Nothing -> Nothing ; Just argu -> fpair argu \arg u -> Just (fun arg, u) } } }; instance Monad Parser where { return = pure ; (>>=) x f = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just at -> fpair at \a t -> parse (f a) t } }; sat' f = \h t -> ife (f h) (Just (h, t)) Nothing; sat f = Parser \inp -> flst inp Nothing (sat' f); instance Functor Parser where { fmap f x = pure f <*> x }; (<|>) x y = Parser \inp -> case parse x inp of { Nothing -> parse y inp ; Just at -> Just at }; (<$>) = fmap; liftA2 f x y = f <$> x <*> y; (*>) = liftA2 \x y -> y; (<*) = liftA2 \x y -> x; many p = liftA2 (:) p (many p) <|> pure []; some p = liftA2 (:) p (many p); sepBy1 p sep = liftA2 (:) p (many (sep *> p)); sepBy p sep = sepBy1 p sep <|> pure []; char c = sat \x -> x == c; between x y p = x *> (p <* y); com = char '-' *> between (char '-') (char '\n') (many (sat \c -> not (c == '\n'))); sp = many ((wrap <$> (sat (\c -> (c == ' ') || (c == '\n')))) <|> com); spc f = f <* sp; spch = spc . char; wantWith pred f = Parser \inp -> case parse f inp of { Nothing -> Nothing ; Just at -> ife (pred $ fst at) (Just at) Nothing }; want f s = wantWith (s ==) f; paren = between (spch '(') (spch ')'); small = sat \x -> ((x <= 'z') && ('a' <= x)) || (x == '_'); large = sat \x -> (x <= 'Z') && ('A' <= x); digit = sat \x -> (x <= '9') && ('0' <= x); symbo = sat \c -> elem c "!#$%&*+./<=>?@\\^|-~"; varLex = liftA2 (:) small (many (small <|> large <|> digit <|> char '\'')); conId = spc (liftA2 (:) large (many (small <|> large <|> digit <|> char '\''))); keyword s = spc $ want varLex s; varId = spc $ wantWith (\s -> not $ elem s ["class", "data", "instance", "of", "where", "if", "then", "else"]) varLex; opTail = many $ char ':' <|> symbo; conSym = spc $ liftA2 (:) (char ':') opTail; varSym = spc $ liftA2 (:) symbo opTail; con = conId <|> paren conSym; var = varId <|> paren varSym; op = varSym <|> conSym <|> between (spch '`') (spch '`') (conId <|> varId); conop = conSym <|> between (spch '`') (spch '`') conId; escChar = char '\\' *> ((sat (\c -> elem c "'\"\\")) <|> ((\c -> '\n') <$> char 'n')); litOne delim = escChar <|> sat \c -> not (c == delim); litInt = Const . foldl (\n d -> 10*n + ord d - ord '0') 0 <$> spc (some digit); litStr = between (char '"') (spch '"') $ many (litOne '"'); litChar = Const . ord <$> between (char '\'') (spch '\'') (litOne '\''); lit = E <$> (StrCon <$> litStr <|> litChar <|> litInt); sqLst r = between (spch '[') (spch ']') $ sepBy r (spch ','); gcon = conId <|> paren (conSym <|> (wrap <$> spch ',')) <|> ((:) <$> spch '[' <*> (wrap <$> spch ']')); apat' r = PatVar <$> var <*> (want varSym "@" *> (Just <$> apat' r) <|> pure Nothing) <|> flip PatCon [] <$> gcon <|> PatPred . A (V "if#") . A (V "==") <$> lit <|> foldr (\h t -> PatCon ":" [h, t]) (PatCon "[]" []) <$> sqLst r <|> paren ((&) <$> r <*> ((spch ',' *> ((\y x -> PatCon "," [x, y]) <$> r)) <|> pure id)) ; pat = PatCon <$> gcon <*> many (apat' pat) <|> (&) <$> apat' pat <*> ((\s r l -> PatCon s [l, r]) <$> conop <*> apat' pat <|> pure id); apat = apat' pat; alt r = (,) <$> pat <*> (want varSym "->" *> r); braceSep f = between (spch '{') (spch '}') (sepBy f (spch ';')); alts r = braceSep (alt r); cas r = Ca <$> between (keyword "case") (keyword "of") r <*> alts r; lamCase r = keyword "case" *> (L "\\case" . Ca (V "\\case") <$> alts r); onePat vs x = Pa [(vs, x)]; lam r = spch '\\' *> (lamCase r <|> liftA2 onePat (some apat) (char '-' *> (spch '>' *> r))); flipPairize y x = A (A (V ",") x) y; thenComma r = spch ',' *> ((flipPairize <$> r) <|> pure (A (V ","))); parenExpr r = (&) <$> r <*> (((\v a -> A (V v) a) <$> op) <|> thenComma r <|> pure id); rightSect r = ((\v a -> L "@" $ A (A (V v) $ V "@") a) <$> (op <|> (wrap <$> spch ','))) <*> r; section r = spch '(' *> (parenExpr r <* spch ')' <|> rightSect r <* spch ')' <|> spch ')' *> pure (V "()")); isFreePat v = \case { PatPred _ -> False ; PatVar s m -> s == v || maybe False (isFreePat v) m ; PatCon _ args -> any (isFreePat v) args }; isFree v expr = case expr of { E _ -> False ; V s -> s == v ; A x y -> isFree v x || isFree v y ; L w t -> not (v == w) && isFree v t ; Pa vsts -> any (\vst -> fpair vst \vs t -> not (any (isFreePat v) vs) && isFree v t) vsts ; Ca x as -> isFree v x || isFree v (Pa $ first (:[]) <$> as) }; freeCount v expr = case expr of { E _ -> 0 ; V s -> ife (s == v) 1 0 ; A x y -> freeCount v x + freeCount v y ; L w t -> ife (v == w) 0 $ freeCount v t ; Pa vsts -> foldr (+) 0 $ map (\vst -> fpair vst \vs t -> ife (any (isFreePat v) vs) 0 $ freeCount v t) vsts ; Ca x as -> freeCount v x + freeCount v (Pa $ first (:[]) <$> as) }; overFree s f t = case t of { E _ -> t ; V s' -> ife (s == s') (f t) t ; A x y -> A (overFree s f x) (overFree s f y) ; L s' t' -> ife (s == s') t $ L s' $ overFree s f t' ; Pa vsxs -> Pa $ map (\vsx -> fpair vsx \vs x -> ife (any (isFreePat s) vs) vsx (vs, overFree s f x)) vsxs ; Ca x as -> Ca (overFree s f x) $ map (\vx -> fpair vx \v x -> ife (isFreePat s v) vx (v, overFree s f x)) as }; beta s t x = overFree s (const t) x; optiApp s x = let { n = freeCount s x } in ife (2 <= n) (A $ L s x) $ ife (0 == n) (const x) (flip (beta s) x); maybeFix s x = ife (isFree s x) (A (ro 'Y') (L s x)) x; opDef x f y rhs = (f, onePat [x, y] rhs); coalesce ds = flst ds [] \h t -> flst t [h] \h' t' -> fpair h' \s' x' -> fpair h \s x -> ife (s == s') ( let { bad = error "bad multidef" } in case x of { E _ -> bad ; V _ -> bad ; A _ _ -> bad ; L _ _ -> bad ; Pa vsts -> case x' of { E _ -> bad ; V _ -> bad ; A _ _ -> bad ; L _ _ -> bad ; Pa vsts' -> coalesce $ (s, Pa $ vsts ++ vsts'):t' ; Ca _ _ -> bad } ; Ca _ _ -> bad } ) $ h:coalesce t ; def r = opDef <$> apat <*> varSym <*> apat <*> (spch '=' *> r) <|> liftA2 (,) var (liftA2 onePat (many apat) (spch '=' *> r)); addLets ls x = foldr (\p t -> fpair p (\name def -> optiApp name t $ maybeFix name def)) x ls; letin r = addLets <$> between (keyword "let") (keyword "in") (coalesce <$> braceSep (def r)) <*> r; ifthenelse r = (\a b c -> A (A (A (V "if") a) b) c) <$> (keyword "if" *> r) <*> (keyword "then" *> r) <*> (keyword "else" *> r); listify = foldr (\h t -> A (A (V ":") h) t) (V "[]"); atom r = ifthenelse r <|> letin r <|> listify <$> sqLst r <|> section r <|> cas r <|> lam r <|> (paren (spch ',') *> pure (V ",")) <|> fmap V (con <|> var) <|> lit; aexp r = fmap (foldl1 A) (some (atom r)); fix f = f (fix f); data Assoc = NAssoc | LAssoc | RAssoc; eqAssoc x y = case x of { NAssoc -> case y of { NAssoc -> True ; LAssoc -> False ; RAssoc -> False } ; LAssoc -> case y of { NAssoc -> False ; LAssoc -> True ; RAssoc -> False } ; RAssoc -> case y of { NAssoc -> False ; LAssoc -> False ; RAssoc -> True } }; precOf s precTab = fmaybe (lookup s precTab) 9 fst; assocOf s precTab = fmaybe (lookup s precTab) LAssoc snd; opWithPrec precTab n = wantWith (\s -> n == precOf s precTab) op; opFold precTab e xs = case xs of { [] -> e ; (:) x xt -> case find (\y -> not (eqAssoc (assocOf (fst x) precTab) (assocOf (fst y) precTab))) xt of { Nothing -> case assocOf (fst x) precTab of { NAssoc -> case xt of { [] -> fpair x (\op y -> A (A (V op) e) y) ; (:) y yt -> undefined } ; LAssoc -> foldl (\a b -> fpair b (\op y -> A (A (V op) a) y)) e xs ; RAssoc -> (foldr (\a b -> fpair a (\op y -> \e -> A (A (V op) e) (b y))) id xs) e } ; Just y -> undefined } }; expr precTab = fix \r n -> ife (n <= 9) (liftA2 (opFold precTab) (r (succ n)) (many (liftA2 (\a b -> (a,b)) (opWithPrec precTab n) (r (succ n))))) (aexp (r 0)); bType r = foldl1 TAp <$> some r; _type r = foldr1 arr <$> sepBy (bType r) (spc (want varSym "->")); typeConst = (\s -> ife (s == "String") (TAp (TC "[]") (TC "Int")) (TC s)) <$> conId; aType = spch '(' *> (spch ')' *> pure (TC "()") <|> ((&) <$> _type aType <*> ((spch ',' *> ((\a b -> TAp (TAp (TC ",") b) a) <$> _type aType)) <|> pure id)) <* spch ')') <|> typeConst <|> (TV <$> varId) <|> (spch '[' *> (spch ']' *> pure (TC "[]") <|> TAp (TC "[]") <$> (_type aType <* spch ']'))); simpleType c vs = foldl TAp (TC c) (map TV vs); -- Can we reduce backtracking here? constr = (\x c y -> Constr c [x, y]) <$> aType <*> conSym <*> aType <|> Constr <$> conId <*> many aType; adt = addAdt <$> between (keyword "data") (spch '=') (simpleType <$> conId <*> many varId) <*> sepBy constr (spch '|'); prec = (\c -> ord c - ord '0') <$> spc digit; fixityList a n os = map (\o -> (o, (n, a))) os; fixityDecl kw a = between (keyword kw) (spch ';') (fixityList a <$> prec <*> sepBy op (spch ',')); fixity = fixityDecl "infix" NAssoc <|> fixityDecl "infixl" LAssoc <|> fixityDecl "infixr" RAssoc; genDecl = (,) <$> var <*> (char ':' *> spch ':' *> _type aType); classDecl = keyword "class" *> (addClass <$> conId <*> (TV <$> varId) <*> (keyword "where" *> braceSep genDecl)); inst = _type aType; instDecl r = keyword "instance" *> ((\ps cl ty defs -> addInst cl (Qual ps ty) defs) <$> (((wrap .) . Pred <$> conId <*> (inst <* want varSym "=>")) <|> pure []) <*> conId <*> inst <*> (keyword "where" *> (coalesce <$> braceSep (def r)))); ffiDecl = keyword "ffi" *> (addFFI <$> litStr <*> var <*> (char ':' *> spch ':' *> _type aType)); tops precTab = sepBy ( adt <|> classDecl <|> instDecl (expr precTab 0) <|> ffiDecl <|> addDefs . coalesce <$> sepBy1 (def $ expr precTab 0) (spch ';') <|> keyword "export" *> (addExport <$> litStr <*> var) ) (spch ';'); program' = sp *> (((":", (5, RAssoc)):) . concat <$> many fixity) >>= tops; -- Primitives. program = parse $ ( [ addAdt (TC "Bool") [Constr "True" [], Constr "False" []] , addAdt (TAp (TC "[]") (TV "a")) [Constr "[]" [], Constr ":" [TV "a", TAp (TC "[]") (TV "a")]] , addAdt (TAp (TAp (TC ",") (TV "a")) (TV "b")) [Constr "," [TV "a", TV "b"]]] ++) <$> program'; prims = let { ii = arr (TC "Int") (TC "Int") ; iii = arr (TC "Int") ii ; bin s = A (ro 'Q') (ro s) } in map (second (first noQual)) $ [ ("intEq", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin '=')) , ("intLE", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin 'L')) , ("charEq", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin '=')) , ("charLE", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin 'L')) , ("if", (arr (TC "Bool") $ arr (TV "a") $ arr (TV "a") (TV "a"), ro 'I')) -- Pattern matching helper: , ("if#", (arr (arr (TV "a") $ TC "Bool") $ arr (TV "a") $ arr (TV "b") $ arr (TV "b") (TV "b"), ro 'I')) , ("()", (TC "()", ro 'K')) , ("chr", (ii, ro 'I')) , ("ord", (ii, ro 'I')) , ("succ", (ii, A (ro 'T') (A (E $ Const $ 1) (ro '+')))) , ("ioBind", (arr (TAp (TC "IO") (TV "a")) (arr (arr (TV "a") (TAp (TC "IO") (TV "b"))) (TAp (TC "IO") (TV "b"))), ro 'C')) , ("ioPure", (arr (TV "a") (TAp (TC "IO") (TV "a")), A (A (ro 'B') (ro 'C')) (ro 'T'))) , ("exitSuccess", (TAp (TC "IO") (TV "a"), ro '.')) , ("unsafePerformIO", (arr (TAp (TC "IO") (TV "a")) (TV "a"), A (A (ro 'C') (A (ro 'T') (ro '?'))) (ro 'K'))) ] ++ map (\s -> (wrap s, (iii, bin s))) "+-*/%"; -- Conversion to De Bruijn indices. data LC = Ze | Su LC | Pass Int | La LC | App LC LC; debruijn m n e = case e of { E x -> case x of { Basic b -> Pass b ; Const c -> App (Pass $ ord '#') (Pass c) ; StrCon s -> foldr (\h t -> App (App (Pass $ ord ':') (App (Pass $ ord '#') (Pass $ ord h))) t) (Pass $ ord 'K') s ; Proof _ -> undefined } ; V v -> maybe (fmaybe (mlookup v m) undefined Pass) id $ foldr (\h found -> ife (h == v) (Just Ze) (maybe Nothing (Just . Su) found)) Nothing n ; A x y -> App (debruijn m n x) (debruijn m n y) ; L s t -> La (debruijn m (s:n) t) ; Pa _ -> undefined ; Ca _ _ -> undefined }; -- Kiselyov bracket abstraction. data IntTree = Lf Int | Nd IntTree IntTree; data Sem = Defer | Closed IntTree | Need Sem | Weak Sem; lf = Lf . ord; ldef = \r y -> case y of { Defer -> Need (Closed (Nd (Nd (lf 'S') (lf 'I')) (lf 'I'))) ; Closed d -> Need (Closed (Nd (lf 'T') d)) ; Need e -> Need (r (Closed (Nd (lf 'S') (lf 'I'))) e) ; Weak e -> Need (r (Closed (lf 'T')) e) }; lclo = \r d y -> case y of { Defer -> Need (Closed d) ; Closed dd -> Closed (Nd d dd) ; Need e -> Need (r (Closed (Nd (lf 'B') d)) e) ; Weak e -> Weak (r (Closed d) e) }; lnee = \r e y -> case y of { Defer -> Need (r (r (Closed (lf 'S')) e) (Closed (lf 'I'))) ; Closed d -> Need (r (Closed (Nd (lf 'R') d)) e) ; Need ee -> Need (r (r (Closed (lf 'S')) e) ee) ; Weak ee -> Need (r (r (Closed (lf 'C')) e) ee) }; lwea = \r e y -> case y of { Defer -> Need e ; Closed d -> Weak (r e (Closed d)) ; Need ee -> Need (r (r (Closed (lf 'B')) e) ee) ; Weak ee -> Weak (r e ee) }; babsa x y = case x of { Defer -> ldef babsa y ; Closed d -> lclo babsa d y ; Need e -> lnee babsa e y ; Weak e -> lwea babsa e y }; babs t = case t of { Ze -> Defer ; Su x -> Weak (babs x) ; Pass n -> Closed (Lf n) ; La t -> case babs t of { Defer -> Closed (lf 'I') ; Closed d -> Closed (Nd (lf 'K') d) ; Need e -> e ; Weak e -> babsa (Closed (lf 'K')) e } ; App x y -> babsa (babs x) (babs y) }; nolam m x = case babs $ debruijn m [] x of { Defer -> undefined ; Closed d -> d ; Need e -> undefined ; Weak e -> undefined }; isLeaf t c = case t of { Lf n -> n == ord c ; Nd _ _ -> False }; optim t = case t of { Lf n -> t ; Nd x y -> let { p = optim x ; q = optim y } in ife (isLeaf p 'I') q $ ife (isLeaf q 'I') ( ife (isLeaf p 'C') (Lf $ ord 'T') $ ife (isLeaf p 'B') (Lf $ ord 'I') $ Nd p q ) $ Nd p q }; enc mem t = case optim t of { Lf n -> (n, mem) ; Nd x y -> fpair mem \hp bs -> let { pm qm = enc (hp + 2, bs . (fst (pm qm):) . (fst qm:)) x ; qm = enc (snd $ pm qm) y } in (hp, snd qm) }; asm qas = foldl (\tabmem def -> fpair def \s qt -> fpair tabmem \tab mem -> fpair (enc mem $ nolam (insert s (fst mem) tab) $ snd qt) \p m' -> let -- Definitions like "t = t;" must be handled with care. { m'' = fpair m' \hp bs -> ife (p == hp) (hp + 2, bs . (ord 'I':) . (p:)) m' } in (insert s p tab, m'')) (Tip, (128, id)) qas; -- Type checking. apply sub t = case t of { TC v -> t ; TV v -> fmaybe (lookup v sub) t id ; TAp a b -> TAp (apply sub a) (apply sub b) }; (@@) s1 s2 = map (second (apply s1)) s2 ++ s1; occurs s t = case t of { TC v -> False ; TV v -> s == v ; TAp a b -> occurs s a || occurs s b }; varBind s t = case t of { TC v -> Just [(s, t)] ; TV v -> ife (v == s) (Just []) (Just [(s, t)]) ; TAp a b -> ife (occurs s t) Nothing (Just [(s, t)]) }; charIsInt s = ife (s == "Char") "Int" s; mgu unify t u = case t of { TC a -> case u of { TC b -> ife (charIsInt a == charIsInt b) (Just []) Nothing ; TV b -> varBind b t ; TAp a b -> Nothing } ; TV a -> varBind a u ; TAp a b -> case u of { TC b -> Nothing ; TV b -> varBind b t ; TAp c d -> unify b d (mgu unify a c) } }; unify a b = maybe Nothing \s -> (@@ s) <$> (mgu unify (apply s a) (apply s b)); --instantiate' :: Type -> Int -> [(String, Type)] -> ((Type, Int), [(String, Type)]) instantiate' t n tab = case t of { TC s -> ((t, n), tab) ; TV s -> case lookup s tab of { Nothing -> let { va = TV (showInt n "") } in ((va, n + 1), (s, va):tab) ; Just v -> ((v, n), tab) } ; TAp x y -> fpair (instantiate' x n tab) \tn1 tab1 -> fpair tn1 \t1 n1 -> fpair (instantiate' y n1 tab1) \tn2 tab2 -> fpair tn2 \t2 n2 -> ((TAp t1 t2, n2), tab2) }; instantiatePred pred xyz = case pred of { Pred s t -> fpair xyz \xy tab -> fpair xy \out n -> first (first ((:out) . Pred s)) (instantiate' t n tab) }; --instantiate :: Qual -> Int -> (Qual, Int) instantiate qt n = case qt of { Qual ps t -> fpair (foldr instantiatePred (([], n), []) ps) \xy tab -> fpair xy \ps1 n1 -> first (Qual ps1) (fst (instantiate' t n1 tab)) }; --type SymTab = [(String, (Qual, Ast))]; --type Subst = [(String, Type)]; singleOut s cs = \scrutinee x -> foldl A (A (V $ specialCase cs) scrutinee) $ map (\c' -> case c' of { Constr s' ts -> ife (s == s') x $ foldr L (V "patjoin#") $ map (const "_") ts }) cs; unpat dcs n as x = case as of { [] -> (x, n) ; a:at -> let { freshv = showInt n "#" } in first (L freshv) $ case a of { PatPred pre -> unpat dcs (n + 1) at $ A (A (A pre $ V freshv) x) $ V "patjoin#" ; PatVar s m -> maybe id (error "TODO") m $ unpat dcs (n + 1) at $ beta s (V freshv) x ; PatCon con args -> case lookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> fpair (unpat dcs (n + 1) args x) \y n1 -> unpat dcs n1 at $ singleOut con cons (V freshv) y } } }; unpatTop dcs n als x = case als of { [] -> (x, n) ; al:alt -> fpair al \a l -> let { go p t = case p of { PatPred pre -> unpatTop dcs n alt $ A (A (A pre $ V l) t) $ V "patjoin#" ; PatVar s m -> maybe (unpatTop dcs n alt) go m $ beta s (V l) t ; PatCon con args -> case lookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> fpair (unpat dcs n args t) \y n1 -> unpatTop dcs n1 alt $ singleOut con cons (V l) y } } } in go a x }; rewritePats' dcs asxs ls n = case asxs of { [] -> (A (V "unsafePerformIO") (V "exitSuccess"), n) ; (:) asx asxt -> fpair asx \as x -> fpair (unpatTop dcs n (zip as ls) x) \y n1 -> first (optiApp "patjoin#" y) $ rewritePats' dcs asxt ls n1 }; rewritePats dcs vsxs n = let { ls = map (flip showInt "#") $ take (length $ flst vsxs undefined \h _ -> fst h) $ upFrom n } in first (flip (foldr L) ls) $ rewritePats' dcs vsxs ls $ n + length ls; classifyAlt v x = case v of { PatPred pre -> Left $ A (A (A pre $ V "of") x) ; PatVar s m -> maybe (Left . optiApp "casejoin#") classifyAlt m $ A (L s x) $ V "of" ; PatCon s ps -> Right (insertWith (flip (.)) s ((ps, x):)) }; genCase dcs tab = ife (size tab == 0) id $ optiApp "casejoin#" $ let { firstC = flst (toAscList tab) undefined (\h _ -> fst h) ; cs = maybe (error "bad constructor") id $ lookup firstC dcs } in foldl A (A (V $ specialCase cs) (V "of")) $ map (\c -> case c of { Constr s ts -> case mlookup s tab of { Nothing -> foldr L (V "casejoin#") $ const "_" <$> ts ; Just f -> Pa $ f [(const (PatVar "_" Nothing) <$> ts, V "casejoin#")] }}) cs; updateCaseSt dcs st alt = fpair st \acc tab -> case alt of { Left f -> (acc . genCase dcs tab . f, Tip) ; Right upd -> (acc, upd tab) }; rewriteCase dcs as = fpair (foldl (updateCaseSt dcs) (id, Tip) $ uncurry classifyAlt <$> as) \acc tab -> acc . genCase dcs tab $ A (V "unsafePerformIO") (V "exitSuccess"); --type AdtTab = [(String, Ast -> Ast)] --infer :: AdtTab -> SymTab -> Subst -> Ast -> (Maybe Subst, Int) -> ((Type, Ast), (Maybe Subst, Int)) infer dcs typed loc ast csn = fpair csn \cs n -> let { va = TV (showInt n "") ; insta ty = fpair (instantiate ty n) \q n1 -> case q of { Qual preds ty -> ((ty, foldl A ast (map (E . Proof) preds)), (cs, n1)) } } in case ast of { E x -> case x of { Basic b -> ife (b == ord 'Y') (insta $ noQual $ arr (arr (TV "a") (TV "a")) (TV "a")) undefined ; Const c -> ((TC "Int", ast), csn) ; StrCon _ -> ((TAp (TC "[]") (TC "Int"), ast), csn) ; Proof _ -> undefined } ; V s -> fmaybe (lookup s loc) (fmaybe (lookup s typed) (error $ "bad symbol: " ++ s) $ insta . fst) ((, csn) . (, ast)) ; A x y -> fpair (infer dcs typed loc x (cs, n + 1)) \tax csn1 -> fpair tax \tx ax -> fpair (infer dcs typed loc y csn1) \tay csn2 -> fpair tay \ty ay -> ((va, A ax ay), first (unify tx (arr ty va)) csn2) ; L s x -> first (\ta -> fpair ta \t a -> (arr va t, L s a)) (infer dcs typed ((s, va):loc) x (cs, n + 1)) ; Pa vsxs -> fpair (rewritePats dcs vsxs n) \re n1 -> infer dcs typed loc re (cs, n1) ; Ca x as -> infer dcs typed loc (optiApp "of" (rewriteCase dcs as) x) csn }; onType f pred = case pred of { Pred s t -> Pred s (f t) }; instance Eq Type where { (==) t u = case t of { TC s -> case u of { TC t -> t == s ; TV _ -> False ; TAp _ _ -> False } ; TV s -> case u of { TC _ -> False ; TV t -> t == s ; TAp _ _ -> False } ; TAp a b -> case u of { TC _ -> False ; TV _ -> False ; TAp c d -> a == c && b == d } }}; instance Eq Pred where { (==) p q = case p of { Pred s a -> case q of { Pred t b -> s == t && a == b }}}; predApply sub p = onType (apply sub) p; filter f = foldr (\x xs ->ife (f x) (x:xs) xs) []; intersect xs ys = filter (\x -> fmaybe (find (x ==) ys) False (\_ -> True)) xs; merge s1 s2 = ife (all (\v -> apply s1 (TV v) == apply s2 (TV v)) $ map fst s1 `intersect` map fst s2) (Just $ s1 ++ s2) Nothing; match h t = case h of { TC a -> case t of { TC b -> ife (a == b) (Just []) Nothing ; TV b -> Nothing ; TAp a b -> Nothing } ; TV a -> Just [(a, t)] ; TAp a b -> case t of { TC b -> Nothing ; TV b -> Nothing ; TAp c d -> case match a c of { Nothing -> Nothing ; Just ac -> case match b d of { Nothing -> Nothing ; Just bd -> merge ac bd } } } }; matchPred h p = case p of { Pred _ t -> match h t }; showType t = case t of { TC s -> s ; TV s -> s ; TAp a b -> concat ["(", showType a, " ", showType b, ")"] }; showPred p = case p of { Pred s t -> s ++ (' ':showType t) ++ " => "}; findInst r qn p insts = case insts of { [] -> fpair qn \q n -> let { v = '*':showInt n "" } in (((p, v):q, n + 1), V v) ; (:) i is -> case i of { Qual ps h -> case matchPred h p of { Nothing -> findInst r qn p is ; Just u -> foldl (\qnt p -> fpair qnt \qn1 t -> second (A t) (r (predApply u p) qn1)) (qn, V (case p of { Pred s _ -> showPred $ Pred s h})) ps }}}; findProof is pred psn = fpair psn \ps n -> case lookup pred ps of { Nothing -> case pred of { Pred s t -> case lookup s is of { Nothing -> error $ "no instances: " ++ s ; Just insts -> findInst (findProof is) psn pred insts }} ; Just s -> (psn, V s) }; prove' ienv sub psn a = case a of { E x -> case x of { Basic _ -> (psn, a) ; Const _ -> (psn, a) ; StrCon _ -> (psn, a) ; Proof raw -> findProof ienv (predApply sub raw) psn } ; V _ -> (psn, a) ; A x y -> let { p1 = prove' ienv sub psn x } in fpair p1 \psn1 x1 -> second (A x1) (prove' ienv sub psn1 y) ; L s t -> second (L s) (prove' ienv sub psn t) ; Pa _ -> undefined ; Ca _ _ -> undefined }; --prove :: [(String, [Qual])] -> (Type, Ast) -> Subst -> (Qual, Ast) prove ienv s ta sub = fpair ta \t a -> fpair (prove' ienv sub ([], 0) a) \psn x -> fpair psn \ps _ -> let { applyDicts expr = foldl A expr $ map (V . snd) ps } in (Qual (map fst ps) (apply sub t), foldr L (overFree s applyDicts x) $ map snd ps); dictVars ps n = flst ps ([], n) \p pt -> first ((p, '*':showInt n ""):) (dictVars pt $ n + 1); -- qi = Qual of instance, e.g. Eq t => [t] -> [t] -> Bool inferMethod ienv dcs typed qi def = fpair def \s expr -> fpair (infer dcs typed [] expr (Just [], 0)) \ta msn -> case lookup s typed of { Nothing -> error $ "no such method: " ++ s -- e.g. qac = Eq a => a -> a -> Bool, some AST (product of single method) ; Just qac -> fpair msn \ms n -> case ms of { Nothing -> error "method: type mismatch" ; Just sub -> fpair (instantiate (fst qac) n) \q1 n1 -> case q1 of { Qual psc tc -> case psc of { [] -> undefined -- Unreachable. ; (:) headPred shouldBeNull -> case qi of { Qual psi ti -> case headPred of { Pred _ headT -> case match headT ti of { Nothing -> undefined -- e.g. Eq t => [t] -> [t] -> Bool -- instantiate and match it against type of ta ; Just subc -> fpair (instantiate (Qual psi $ apply subc tc) n1) \q2 n2 -> case q2 of { Qual ps2 t2 -> fpair ta \tx ax -> case match (apply sub tx) t2 of { Nothing -> error "class/instance type conflict" ; Just subx -> snd $ prove' ienv (subx @@ sub) (dictVars ps2 0) ax }}}}}}}}}; inferInst ienv dcs typed inst = fpair inst \cl qds -> fpair qds \q ds -> case q of { Qual ps t -> let { s = showPred $ Pred cl t } in (s, (,) (noQual $ TC "DICT") $ foldr L (L "@" $ foldl A (V "@") (map (inferMethod ienv dcs typed q) ds)) (map snd $ fst $ dictVars ps 0)) }; reverse = foldl (flip (:)) []; inferDefs ienv defs dcs typed = flst defs (Right $ reverse typed) \edef rest -> case edef of { Left def -> fpair def \s expr -> fpair (infer dcs typed [(s, TV "self!")] expr (Just [], 0)) \ta msn -> fpair msn \ms _ -> case prove ienv s ta <$> (unify (TV "self!") (fst ta) ms) of { Nothing -> Left ("bad type: " ++ s) ; Just qa -> inferDefs ienv rest dcs ((s, qa):typed) } ; Right inst -> inferDefs ienv rest dcs (inferInst ienv dcs typed inst:typed) }; showQual q = case q of { Qual ps t -> concatMap showPred ps ++ showType t }; untangle = foldr ($) (Neat [] [] prims [] [] []); dumpTypes s = fmaybe (program s) "parse error" \progRest -> fpair progRest \prog rest -> fneat (untangle prog) \ienv fs typed dcs ffis exs -> case inferDefs ienv fs dcs typed of { Left err -> err ; Right typed -> concatMap (\p -> fpair p \s qa -> s ++ " :: " ++ showQual (fst qa) ++ "\n") typed }; last' x xt = flst xt x \y yt -> last' y yt; last xs = flst xs undefined last'; init xs = flst xs undefined \x xt -> flst xt [] \_ _ -> x : init xt; intercalate sep xs = flst xs [] \x xt -> x ++ concatMap (sep ++) xt; argList t = case t of { TC s -> [TC s] ; TV s -> [TV s] ; TAp g y -> case g of { TC s -> case y of { TC u -> ife (s == "IO") [TC u] undefined ; TV _ -> undefined ; TAp _ _ -> undefined } ; TV s -> undefined ; TAp f x -> case f of { TC s -> ife (s == "->") (x : argList y) undefined ; TV s -> undefined ; TAp _ _ -> undefined } } }; cTypeName t = case t of { TC s -> ife (s == "()") "void" $ ife (s == "Int") "int" $ ife (s == "Char") "char" $ error $ "bad type constant: " ++ s ; TV _ -> undefined ; TAp _ _ -> undefined }; ffiDeclare namet = fpair namet \name t -> let { tys = argList t } in concat [ cTypeName $ last tys , " " , name , "(" , intercalate "," $ cTypeName <$> init tys , ");\n" ]; ffiArgs n t = case t of { TC s -> ("", ((True, s), n)) ; TV s -> undefined ; TAp g y -> case g of { TC s -> case y of { TC u -> ife (s == "IO") ("", ((False, u), n)) undefined ; TV _ -> undefined ; TAp _ _ -> undefined } ; TV s -> undefined ; TAp f x -> case f of { TC s -> ife (s == "->") (first ((ife (3 <= n) ", " "" ++ "num(" ++ showInt n ")") ++) $ ffiArgs (n + 1) y) undefined ; TV s -> undefined ; TAp _ _ -> undefined } } }; ffiDefine n ffis = case ffis of { [] -> id ; (:) x xt -> fpair x \name t -> fpair (ffiArgs 2 t) \args pRetCount -> fpair pRetCount \pRet count -> fpair pRet \isPure ret -> let { lazyn = ("lazy(" ++) . showInt (ife isPure (count - 1) (count + 1)) . (", " ++) ; aa tgt = "app(arg(" ++ showInt (count + 1) "), " ++ tgt ++ "), arg(" ++ showInt count ")" ; longDistanceCall = name ++ "(" ++ args ++ ")" } in ("case " ++) . showInt n . (": " ++) . ife (ret == "()") ((longDistanceCall ++) . (';':) . lazyn . ((ife isPure "'I', 'K'" (aa "'K'") ++ "); break;") ++) . ffiDefine (n - 1) xt) (lazyn . ((ife isPure ("'#', " ++ longDistanceCall) (aa $ "app('#', " ++ longDistanceCall ++ ")") ++ "); break;") ++) . ffiDefine (n - 1) xt) }; getContents = getChar >>= \n -> ife (n <= 255) ((chr n:) <$> getContents) (pure []); compile s = fmaybe (program s) "parse error" \progRest -> fpair progRest \prog rest -> fneat (untangle prog) \ienv fs typed dcs ffis exs -> case inferDefs ienv fs dcs typed of { Left err -> err ; Right qas -> fpair (asm qas) \tab mem -> (concatMap ffiDeclare ffis ++) . ("static void foreign(u n) {\n switch(n) {\n" ++) . ffiDefine (length ffis - 1) ffis . ("\n }\n}\n" ++) . ("static const u prog[]={" ++) . foldr (.) id (map (\n -> showInt n . (',':)) $ snd mem []) . ("};\nstatic const u prog_size=sizeof(prog)/sizeof(*prog);\n" ++) . ("static u root[]={" ++) . foldr (\p f -> fpair p \x y -> maybe undefined showInt (mlookup y tab) . (", " ++) . f) id exs . ("};\n" ++) . ("static const u root_size=" ++) . showInt (length exs) . (";\n" ++) $ flst exs ("int main(){rts_init();rts_reduce(" ++ maybe undefined showInt (mlookup (fst $ last qas) tab) ");return 0;}") $ \_ _ -> concat $ zipWith (\p n -> "EXPORT(f" ++ showInt n ", \"" ++ fst p ++ "\", " ++ showInt n ")\n") exs (upFrom 0) }; main = getContents >>= putStr . compile;
We predefine the Bool type, as our next compiler will handle guards, which translate to expressions involving booleans.
Guardedly
Our last compiler passed an unfortunate milestone: it’s over 1000 lines long.
We use language features we just added to shrink the code. At the same time, we add support for guards.
Before, the right-hand sides of lambdas, equations, and case alternatives were simply Ast values. We change to the type [(Ast, Ast)], that is, a list of pairs of expressions. During parsing, the guard condition becomes the first element of a pair, and the corresponding expression is the second element. We use a list because there can be multiple guards.
We rewrite guards as chains of if-then-else expressions, where the last else branch is the pattern join point.
Our previous compiler defined charEq and charLE which we use in this compiler to define the typeclass instance for Eq Char. This prepares for treating Int and Char as distinct types in our next compiler.
Doing so will correct a subtle bug. Up until now, a hack treats Int and Char as equal during type checking, but it fails to treat them as equals in dictionaries; for example, Eq Char differs to Eq Int. We could have fixed this by treating Char as a type synonym for Int in the same way String is a type synonym for [Char], but this breaks FFI typing.
-- Guards. infixr 9 .; infixl 7 * , / , %; infixl 6 + , -; infixr 5 ++; infixl 4 <*> , <$> , <* , *>; infix 4 == , /= , <=; infixl 3 && , <|>; infixl 2 ||; infixl 1 >> , >>=; infixr 0 $; ffi "putchar" putChar :: Int -> IO Int; ffi "getchar" getChar :: IO Int; class Functor f where { fmap :: (a -> b) -> f a -> f b }; class Applicative f where { pure :: a -> f a ; (<*>) :: f (a -> b) -> f a -> f b }; class Monad m where { return :: a -> m a ; (>>=) :: m a -> (a -> m b) -> m b }; (>>) f g = f >>= \_ -> g; class Eq a where { (==) :: a -> a -> Bool }; instance Eq Int where { (==) = intEq }; instance Eq Char where { (==) = charEq }; ($) f x = f x; id x = x; const x y = x; flip f x y = f y x; (&) x f = f x; class Ord a where { (<=) :: a -> a -> Bool }; instance Ord Int where { (<=) = intLE }; instance Ord Char where { (<=) = charLE }; data Ordering = LT | GT | EQ; compare x y = case x <= y of { True -> case y <= x of { True -> EQ ; False -> LT } ; False -> GT }; instance Ord a => Ord [a] where { (<=) xs ys = case xs of { [] -> True ; x:xt -> case ys of { [] -> False ; y:yt -> case compare x y of { LT -> True ; GT -> False ; EQ -> xt <= yt } } } }; data Maybe a = Nothing | Just a; data Either a b = Left a | Right b; fpair (x, y) f = f x y; fst (x, y) = x; snd (x, y) = y; uncurry f (x, y) = f x y; first f (x, y) = (f x, y); second f (x, y) = (x, f y); not a = if a then False else True; x /= y = not $ x == y; (.) f g x = f (g x); (||) f g = if f then True else g; (&&) f g = if f then g else False; flst xs n c = case xs of { [] -> n; h:t -> c h t }; instance Eq a => Eq [a] where { (==) xs ys = case xs of { [] -> case ys of { [] -> True ; _ -> False } ; x:xt -> case ys of { [] -> False ; y:yt -> x == y && xt == yt } }}; take n xs = if n == 0 then [] else flst xs [] \h t -> h:take (n - 1) t; maybe n j m = case m of { Nothing -> n; Just x -> j x }; fmaybe m n j = case m of { Nothing -> n; Just x -> j x }; instance Functor Maybe where { fmap f = maybe Nothing (Just . f) }; foldr c n l = flst l n (\h t -> c h(foldr c n t)); length = foldr (\_ n -> n + 1) 0; mapM_ f = foldr ((>>) . f) (pure ()); instance Applicative IO where { pure = ioPure ; (<*>) f x = ioBind f \g -> ioBind x \y -> ioPure (g y) }; instance Monad IO where { return = ioPure ; (>>=) = ioBind }; instance Functor IO where { fmap f x = ioPure f <*> x }; putStr = mapM_ $ putChar . ord; error s = unsafePerformIO $ putStr s >> putChar (ord '\n') >> exitSuccess; undefined = error "undefined"; foldr1 c l@(h:t) = maybe undefined id $ foldr (\x m -> Just $ maybe x (c x) m) Nothing l; foldl f a bs = foldr (\b g x -> g (f x b)) (\x -> x) bs a; foldl1 f (h:t) = foldl f h t; elem k xs = foldr (\x t -> x == k || t) False xs; find f xs = foldr (\x t -> if f x then Just x else t) Nothing xs; (++) = flip (foldr (:)); concat = foldr (++) []; wrap c = c:[]; map = flip (foldr . ((:) .)) []; instance Functor [] where { fmap = map }; concatMap = (concat .) . map; lookup s = foldr (\(k, v) t -> if s == k then Just v else t) Nothing; all f = foldr (&&) True . map f; any f = foldr (||) False . map f; upFrom n = n : upFrom (n + 1); zipWith f xs ys = flst xs [] $ \x xt -> flst ys [] $ \y yt -> f x y : zipWith f xt yt; zip = zipWith (,); -- Map. data Map k a = Tip | Bin Int k a (Map k a) (Map k a); size m = case m of { Tip -> 0 ; Bin sz _ _ _ _ -> sz }; node k x l r = Bin (1 + size l + size r) k x l r; singleton k x = Bin 1 k x Tip Tip; singleL k x l (Bin _ rk rkx rl rr) = node rk rkx (node k x l rl) rr; doubleL k x l (Bin _ rk rkx (Bin _ rlk rlkx rll rlr) rr) = node rlk rlkx (node k x l rll) (node rk rkx rlr rr); singleR k x (Bin _ lk lkx ll lr) r = node lk lkx ll (node k x lr r); doubleR k x (Bin _ lk lkx ll (Bin _ lrk lrkx lrl lrr)) r = node lrk lrkx (node lk lkx ll lrl) (node k x lrr r); balance k x l r = case size l + size r <= 1 of { True -> node ; False -> case 5 * size l + 3 <= 2 * size r of { True -> case r of { Tip -> node ; Bin sz _ _ rl rr -> case 2 * size rl + 1 <= 3 * size rr of { True -> singleL ; False -> doubleL } } ; False -> case 5 * size r + 3 <= 2 * size l of { True -> case l of { Tip -> node ; Bin sz _ _ ll lr -> case 2 * size lr + 1 <= 3 * size ll of { True -> singleR ; False -> doubleR } } ; False -> node } } } k x l r; insert kx x t = case t of { Tip -> singleton kx x ; Bin sz ky y l r -> case compare kx ky of { LT -> balance ky y (insert kx x l) r ; GT -> balance ky y l (insert kx x r) ; EQ -> Bin sz kx x l r } }; insertWith f kx x t = case t of { Tip -> singleton kx x ; Bin sy ky y l r -> case compare kx ky of { LT -> balance ky y (insertWith f kx x l) r ; GT -> balance ky y l (insertWith f kx x r) ; EQ -> Bin sy kx (f x y) l r } }; mlookup kx t = case t of { Tip -> Nothing ; Bin _ ky y l r -> case compare kx ky of { LT -> mlookup kx l ; GT -> mlookup kx r ; EQ -> Just y } }; fromList = foldl (\t (k, x) -> insert k x t) Tip; foldrWithKey f = let { go z t = case t of { Tip -> z ; Bin _ kx x l r -> go (f kx x (go z r)) l } } in go; toAscList = foldrWithKey (\k x xs -> (k,x):xs) []; -- Parsing. data Type = TC String | TV String | TAp Type Type; arr a b = TAp (TAp (TC "->") a) b; data Extra = Basic Int | Const Int | StrCon String | Proof Pred; data Pat = PatPred Ast | PatVar String (Maybe Pat) | PatCon String [Pat]; data Ast = E Extra | V String | A Ast Ast | L String Ast | Pa [([Pat], [(Ast, Ast)])] | Ca Ast [(Pat, [(Ast, Ast)])]; data Parser a = Parser (String -> Maybe (a, String)); data Constr = Constr String [Type]; data Pred = Pred String Type; data Qual = Qual [Pred] Type; noQual = Qual []; data Neat = Neat -- | Instance environment. (Map String [Qual]) -- | Either top-level or instance definitions. [Either (String, Ast) (String, (Qual, [(String, Ast)]))] -- | Typed ASTs, ready for compilation, including ADTs and methods, -- e.g. (==), (Eq a => a -> a -> Bool, select-==) [(String, (Qual, Ast))] -- | Data constructor table. (Map String [Constr]) -- AdtTab -- | FFI declarations. [(String, Type)] -- | Exports. [(String, String)] ; fneat (Neat a b c d e f) z = z a b c d e f; ro = E . Basic . ord; conOf (Constr s _) = s; specialCase = concatMap (('|':) . conOf); mkCase t cs = (specialCase cs, ( noQual $ arr t $ foldr arr (TV "case") $ map (\(Constr _ ts) -> foldr arr (TV "case") ts) cs , ro 'I')); mkStrs = snd . foldl (\(s, l) u -> ('@':s, s:l)) ("@", []); scottEncode vs s ts = foldr L (foldl (\a b -> A a (V b)) (V s) ts) (ts ++ vs); scottConstr t cs c = case c of { Constr s ts -> (s, ( noQual $ foldr arr t ts , scottEncode (map conOf cs) s $ mkStrs ts)) }; mkAdtDefs t cs = mkCase t cs : map (scottConstr t cs) cs; mkSel ms s = L "@" $ A (V "@") $ foldr L (V $ '*':s) $ map (('*':) . fst) ms; showInt' n = if 0 == n then id else (showInt' $ n/10) . ((:) (chr $ 48+n%10)); showInt n = if 0 == n then ('0':) else showInt' n; mkFFIHelper n t acc = case t of { TC s -> acc ; TAp (TC "IO") _ -> acc ; TAp (TAp (TC "->") x) y -> L (showInt n "") $ mkFFIHelper (n + 1) y $ A (V $ showInt n "") acc }; updateDcs cs dcs = foldr (\(Constr s _) m -> insert s cs m) dcs cs; addAdt t cs acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs (mkAdtDefs t cs ++ typed) (updateDcs cs dcs) ffis exs; addClass classId v ms acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs (map (\(s, t) -> (s, (Qual [Pred classId v] t, mkSel ms s))) ms ++ typed) dcs ffis exs; addInst cl q ds acc = fneat acc \ienv fs typed dcs ffis exs -> Neat (insertWith (++) cl [q] ienv) (Right (cl, (q, ds)):fs) typed dcs ffis exs; addFFI foreignname ourname t acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs ((ourname, (Qual [] t, mkFFIHelper 0 t $ A (ro 'F') (ro $ chr $ length ffis))) : typed) dcs ((foreignname, t):ffis) exs; addDefs ds acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv (map Left ds ++ fs) typed dcs ffis exs; addExport e f acc = fneat acc \ienv fs typed dcs ffis exs -> Neat ienv fs typed dcs ffis ((e, f):exs); parse (Parser f) inp = f inp; instance Applicative Parser where { pure x = Parser \inp -> Just (x, inp) ; (<*>) x y = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just (fun, t) -> case parse y t of { Nothing -> Nothing ; Just (arg, u) -> Just (fun arg, u) } } }; instance Monad Parser where { return = pure ; (>>=) x f = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just (a, t) -> parse (f a) t } }; sat' f = \h t -> if f h then Just (h, t) else Nothing; sat f = Parser \inp -> flst inp Nothing (sat' f); instance Functor Parser where { fmap f x = pure f <*> x }; (<|>) x y = Parser \inp -> case parse x inp of { Nothing -> parse y inp ; Just at -> Just at }; (<$>) = fmap; liftA2 f x y = f <$> x <*> y; (*>) = liftA2 \x y -> y; (<*) = liftA2 \x y -> x; many p = liftA2 (:) p (many p) <|> pure []; some p = liftA2 (:) p (many p); sepBy1 p sep = liftA2 (:) p (many (sep *> p)); sepBy p sep = sepBy1 p sep <|> pure []; char c = sat (c ==); between x y p = x *> (p <* y); com = char '-' *> between (char '-') (char '\n') (many $ sat ('\n' /=)); sp = many ((wrap <$> (sat (\c -> (c == ' ') || (c == '\n')))) <|> com); spc f = f <* sp; spch = spc . char; wantWith pred f = Parser \inp -> case parse f inp of { Nothing -> Nothing ; Just at -> if pred $ fst at then Just at else Nothing }; paren = between (spch '(') (spch ')'); small = sat \x -> ((x <= 'z') && ('a' <= x)) || (x == '_'); large = sat \x -> (x <= 'Z') && ('A' <= x); digit = sat \x -> (x <= '9') && ('0' <= x); symbo = sat \c -> elem c "!#$%&*+./<=>?@\\^|-~"; varLex = liftA2 (:) small (many (small <|> large <|> digit <|> char '\'')); conId = spc (liftA2 (:) large (many (small <|> large <|> digit <|> char '\''))); varId = spc $ wantWith (\s -> not $ elem s ["class", "data", "instance", "of", "where", "if", "then", "else"]) varLex; opTail = many $ char ':' <|> symbo; conSym = spc $ liftA2 (:) (char ':') opTail; varSym = spc $ wantWith (not . (`elem` ["@", "=", "|", "->", "=>"])) $ liftA2 (:) symbo opTail; con = conId <|> paren conSym; var = varId <|> paren varSym; op = varSym <|> conSym <|> between (spch '`') (spch '`') (conId <|> varId); conop = conSym <|> between (spch '`') (spch '`') conId; escChar = char '\\' *> ((sat (\c -> elem c "'\"\\")) <|> ((\c -> '\n') <$> char 'n')); litOne delim = escChar <|> sat (delim /=); litInt = Const . foldl (\n d -> 10*n + ord d - ord '0') 0 <$> spc (some digit); litChar = Const . ord <$> between (char '\'') (spch '\'') (litOne '\''); litStr = between (char '"') (spch '"') $ many (litOne '"'); lit = E <$> (StrCon <$> litStr <|> litChar <|> litInt); sqLst r = between (spch '[') (spch ']') $ sepBy r (spch ','); want f s = wantWith (s ==) f; tok s = spc $ want (some (char '_' <|> symbo) <|> varLex) s; gcon = conId <|> paren (conSym <|> (wrap <$> spch ',')) <|> ((:) <$> spch '[' <*> (wrap <$> spch ']')); apat' r = PatVar <$> var <*> (tok "@" *> (Just <$> apat' r) <|> pure Nothing) <|> flip PatCon [] <$> gcon <|> PatPred . A (V "if#") . A (V "==") <$> lit <|> foldr (\h t -> PatCon ":" [h, t]) (PatCon "[]" []) <$> sqLst r <|> paren ((&) <$> r <*> ((spch ',' *> ((\y x -> PatCon "," [x, y]) <$> r)) <|> pure id)) ; pat = PatCon <$> gcon <*> many (apat' pat) <|> (&) <$> apat' pat <*> ((\s r l -> PatCon s [l, r]) <$> conop <*> apat' pat <|> pure id); apat = apat' pat; guards s r = tok s *> (wrap . (V "True",) <$> r) <|> some ((,) <$> (spch '|' *> r) <*> (tok s *> r)); alt r = (,) <$> pat <*> guards "->" r; braceSep f = between (spch '{') (spch '}') (sepBy f (spch ';')); alts r = braceSep (alt r); cas r = Ca <$> between (tok "case") (tok "of") r <*> alts r; lamCase r = tok "case" *> (L "\\case" . Ca (V "\\case") <$> alts r); onePat vs x = Pa [(vs, x)]; lam r = spch '\\' *> (lamCase r <|> liftA2 onePat (some apat) (tok "->" *> (wrap . (V "True",) <$> r))); flipPairize y x = A (A (V ",") x) y; thenComma r = spch ',' *> ((flipPairize <$> r) <|> pure (A (V ","))); parenExpr r = (&) <$> r <*> (((\v a -> A (V v) a) <$> op) <|> thenComma r <|> pure id); rightSect r = ((\v a -> L "@" $ A (A (V v) $ V "@") a) <$> (op <|> (wrap <$> spch ','))) <*> r; section r = spch '(' *> (parenExpr r <* spch ')' <|> rightSect r <* spch ')' <|> spch ')' *> pure (V "()")); isFreePat v = \case { PatPred _ -> False ; PatVar s m -> s == v || maybe False (isFreePat v) m ; PatCon _ args -> any (isFreePat v) args }; isFree v expr = case expr of { E _ -> False ; V s -> s == v ; A x y -> isFree v x || isFree v y ; L w t -> v /= w && isFree v t ; Pa vsts -> any (\(vs, gs) -> not (any (isFreePat v) vs) && any (\(g, t) -> isFree v g || isFree v t) gs) vsts ; Ca x as -> isFree v x || isFree v (Pa $ first (:[]) <$> as) }; overFree s f t = case t of { E _ -> t ; V s' -> if s == s' then f t else t ; A x y -> A (overFree s f x) (overFree s f y) ; L s' t' -> if s == s' then t else L s' $ overFree s f t' ; Pa vsxs -> Pa $ map (\vsx@(vs, gs) -> if any (isFreePat s) vs then vsx else (vs, map (\(g, t) -> (overFree s f g, overFree s f t)) gs)) vsxs ; Ca x as -> Ca (overFree s f x) $ map (\vx@(v, gs) -> if isFreePat s v then vx else (v, map (\(g, t) -> (overFree s f g, overFree s f t)) gs)) as }; beta s t x = overFree s (const t) x; maybeFix s x = if isFree s x then A (ro 'Y') (L s x) else x; opDef x f y rhs = (f, onePat [x, y] rhs); coalesce ds = flst ds [] \h@(s, x) t -> flst t [h] \(s', x') t' -> let { f (Pa vsts) (Pa vsts') = Pa $ vsts ++ vsts' ; f _ _ = error "bad multidef" } in if s == s' then coalesce $ (s, f x x'):t' else h:coalesce t; def r = opDef <$> apat <*> varSym <*> apat <*> guards "=" r <|> liftA2 (,) var (liftA2 onePat (many apat) (guards "=" r)); addLets ls x = foldr (\(name, def) t -> A (L name t) $ maybeFix name def) x ls; letin r = addLets <$> between (tok "let") (tok "in") (coalesce <$> braceSep (def r)) <*> r; ifthenelse r = (\a b c -> A (A (A (V "if") a) b) c) <$> (tok "if" *> r) <*> (tok "then" *> r) <*> (tok "else" *> r); listify = foldr (\h t -> A (A (V ":") h) t) (V "[]"); anyChar = sat \_ -> True; rawBody = (char '|' *> char ']' *> pure []) <|> (:) <$> anyChar <*> rawBody; rawQQ = spc $ char '[' *> char 'r' *> char '|' *> (E . StrCon <$> rawBody); atom r = ifthenelse r <|> letin r <|> rawQQ <|> listify <$> sqLst r <|> section r <|> cas r <|> lam r <|> (paren (spch ',') *> pure (V ",")) <|> fmap V (con <|> var) <|> lit; aexp r = fmap (foldl1 A) (some (atom r)); fix f = f (fix f); data Assoc = NAssoc | LAssoc | RAssoc; instance Eq Assoc where { NAssoc == NAssoc = True ; LAssoc == LAssoc = True ; RAssoc == RAssoc = True ; _ == _ = False }; precOf s precTab = fmaybe (lookup s precTab) 9 fst; assocOf s precTab = fmaybe (lookup s precTab) LAssoc snd; opWithPrec precTab n = wantWith (\s -> n == precOf s precTab) op; opFold precTab e xs = case xs of { [] -> e ; x:xt -> case find (\y -> assocOf (fst x) precTab /= assocOf (fst y) precTab) xt of { Nothing -> case assocOf (fst x) precTab of { NAssoc -> case xt of { [] -> fpair x (\op y -> A (A (V op) e) y) ; y:yt -> undefined } ; LAssoc -> foldl (\a (op, y) -> A (A (V op) a) y) e xs ; RAssoc -> foldr (\(op, y) b -> \e -> A (A (V op) e) (b y)) id xs $ e } ; Just y -> undefined } }; expr precTab = fix \r n -> if n <= 9 then liftA2 (opFold precTab) (r $ succ n) (many (liftA2 (,) (opWithPrec precTab n) (r $ succ n))) else aexp (r 0); bType r = foldl1 TAp <$> some r; _type r = foldr1 arr <$> sepBy (bType r) (spc (tok "->")); typeConst = (\s -> if s == "String" then TAp (TC "[]") (TC "Int") else TC s) <$> conId; aType = spch '(' *> (spch ')' *> pure (TC "()") <|> ((&) <$> _type aType <*> ((spch ',' *> ((\a b -> TAp (TAp (TC ",") b) a) <$> _type aType)) <|> pure id)) <* spch ')') <|> typeConst <|> (TV <$> varId) <|> (spch '[' *> (spch ']' *> pure (TC "[]") <|> TAp (TC "[]") <$> (_type aType <* spch ']'))); simpleType c vs = foldl TAp (TC c) (map TV vs); -- Can we reduce backtracking here? constr = (\x c y -> Constr c [x, y]) <$> aType <*> conSym <*> aType <|> Constr <$> conId <*> many aType; adt = addAdt <$> between (tok "data") (spch '=') (simpleType <$> conId <*> many varId) <*> sepBy constr (spch '|'); prec = (\c -> ord c - ord '0') <$> spc digit; fixityList a n os = map (\o -> (o, (n, a))) os; fixityDecl kw a = between (tok kw) (spch ';') (fixityList a <$> prec <*> sepBy op (spch ',')); fixity = fixityDecl "infix" NAssoc <|> fixityDecl "infixl" LAssoc <|> fixityDecl "infixr" RAssoc; genDecl = (,) <$> var <*> (char ':' *> spch ':' *> _type aType); classDecl = tok "class" *> (addClass <$> conId <*> (TV <$> varId) <*> (tok "where" *> braceSep genDecl)); inst = _type aType; instDecl r = tok "instance" *> ((\ps cl ty defs -> addInst cl (Qual ps ty) defs) <$> (((wrap .) . Pred <$> conId <*> (inst <* tok "=>")) <|> pure []) <*> conId <*> inst <*> (tok "where" *> (coalesce <$> braceSep (def r)))); ffiDecl = tok "ffi" *> (addFFI <$> litStr <*> var <*> (char ':' *> spch ':' *> _type aType)); tops precTab = sepBy ( adt <|> classDecl <|> instDecl (expr precTab 0) <|> ffiDecl <|> addDefs . coalesce <$> sepBy1 (def $ expr precTab 0) (spch ';') <|> tok "export" *> (addExport <$> litStr <*> var) ) (spch ';'); program' = sp *> (((":", (5, RAssoc)):) . concat <$> many fixity) >>= tops; -- Primitives. program = parse $ ( [ addAdt (TC "Bool") [Constr "True" [], Constr "False" []] , addAdt (TAp (TC "[]") (TV "a")) [Constr "[]" [], Constr ":" [TV "a", TAp (TC "[]") (TV "a")]] , addAdt (TAp (TAp (TC ",") (TV "a")) (TV "b")) [Constr "," [TV "a", TV "b"]]] ++) <$> program'; prims = let { ii = arr (TC "Int") (TC "Int") ; iii = arr (TC "Int") ii ; bin s = A (ro 'Q') (ro s) } in map (second (first noQual)) $ [ ("intEq", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin '=')) , ("intLE", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin 'L')) , ("charEq", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin '=')) , ("charLE", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin 'L')) , ("if", (arr (TC "Bool") $ arr (TV "a") $ arr (TV "a") (TV "a"), ro 'I')) -- Pattern matching helper: , ("if#", (arr (arr (TV "a") $ TC "Bool") $ arr (TV "a") $ arr (TV "b") $ arr (TV "b") (TV "b"), ro 'I')) , ("()", (TC "()", ro 'K')) , ("chr", (ii, ro 'I')) , ("ord", (ii, ro 'I')) , ("succ", (ii, A (ro 'T') (A (E $ Const $ 1) (ro '+')))) , ("ioBind", (arr (TAp (TC "IO") (TV "a")) (arr (arr (TV "a") (TAp (TC "IO") (TV "b"))) (TAp (TC "IO") (TV "b"))), ro 'C')) , ("ioPure", (arr (TV "a") (TAp (TC "IO") (TV "a")), A (A (ro 'B') (ro 'C')) (ro 'T'))) , ("fail#", (TV "a", A (V "unsafePerformIO") (V "exitSuccess"))) , ("exitSuccess", (TAp (TC "IO") (TV "a"), ro '.')) , ("unsafePerformIO", (arr (TAp (TC "IO") (TV "a")) (TV "a"), A (A (ro 'C') (A (ro 'T') (ro '?'))) (ro 'K'))) ] ++ map (\s -> (wrap s, (iii, bin s))) "+-*/%"; -- Conversion to De Bruijn indices. data LC = Ze | Su LC | Pass Int | La LC | App LC LC; debruijn m n e = case e of { E x -> case x of { Basic b -> Pass b ; Const c -> App (Pass $ ord '#') (Pass c) ; StrCon s -> foldr (\h t -> App (App (Pass $ ord ':') (App (Pass $ ord '#') (Pass $ ord h))) t) (Pass $ ord 'K') s ; Proof _ -> undefined } ; V v -> maybe (fmaybe (mlookup v m) undefined Pass) id $ foldr (\h found -> if h == v then Just Ze else Su <$> found) Nothing n ; A x y -> App (debruijn m n x) (debruijn m n y) ; L s t -> La (debruijn m (s:n) t) }; -- Kiselyov bracket abstraction. data IntTree = Lf Int | Nd IntTree IntTree; data Sem = Defer | Closed IntTree | Need Sem | Weak Sem; lf = Lf . ord; ldef = \r y -> case y of { Defer -> Need (Closed (Nd (Nd (lf 'S') (lf 'I')) (lf 'I'))) ; Closed d -> Need (Closed (Nd (lf 'T') d)) ; Need e -> Need (r (Closed (Nd (lf 'S') (lf 'I'))) e) ; Weak e -> Need (r (Closed (lf 'T')) e) }; lclo = \r d y -> case y of { Defer -> Need (Closed d) ; Closed dd -> Closed (Nd d dd) ; Need e -> Need (r (Closed (Nd (lf 'B') d)) e) ; Weak e -> Weak (r (Closed d) e) }; lnee = \r e y -> case y of { Defer -> Need (r (r (Closed (lf 'S')) e) (Closed (lf 'I'))) ; Closed d -> Need (r (Closed (Nd (lf 'R') d)) e) ; Need ee -> Need (r (r (Closed (lf 'S')) e) ee) ; Weak ee -> Need (r (r (Closed (lf 'C')) e) ee) }; lwea = \r e y -> case y of { Defer -> Need e ; Closed d -> Weak (r e (Closed d)) ; Need ee -> Need (r (r (Closed (lf 'B')) e) ee) ; Weak ee -> Weak (r e ee) }; babsa x y = case x of { Defer -> ldef babsa y ; Closed d -> lclo babsa d y ; Need e -> lnee babsa e y ; Weak e -> lwea babsa e y }; babs t = case t of { Ze -> Defer ; Su x -> Weak (babs x) ; Pass n -> Closed (Lf n) ; La t -> case babs t of { Defer -> Closed (lf 'I') ; Closed d -> Closed (Nd (lf 'K') d) ; Need e -> e ; Weak e -> babsa (Closed (lf 'K')) e } ; App x y -> babsa (babs x) (babs y) }; freeCount v expr = case expr of { E _ -> 0 ; V s -> if s == v then 1 else 0 ; A x y -> freeCount v x + freeCount v y ; L w t -> if v == w then 0 else freeCount v t }; app01 s x = let { n = freeCount s x } in if 2 <= n then A $ L s x else if 0 == n then const x else flip (beta s) x; optiApp t = case t of { A (L s x) y -> app01 s (optiApp x) (optiApp y) ; A x y -> A (optiApp x) (optiApp y) ; L s x -> L s (optiApp x) ; _ -> t }; nolam m x = (\(Closed d) -> d) $ babs $ debruijn m [] $ optiApp x; isLeaf t c = case t of { Lf n -> n == ord c ; _ -> False }; ife a b c = case a of { True -> b ; False -> c }; optim t = case t of { Lf n -> t ; Nd x y -> let { p = optim x ; q = optim y } in ife (isLeaf p 'I') q $ ife (isLeaf q 'I') ( ife (isLeaf p 'C') (Lf $ ord 'T') $ ife (isLeaf p 'B') (Lf $ ord 'I') $ Nd p q ) $ Nd p q }; enc mem t = case optim t of { Lf n -> (n, mem) ; Nd x y -> fpair mem \hp bs -> let { pm qm = enc (hp + 2, bs . (fst (pm qm):) . (fst qm:)) x ; qm = enc (snd $ pm qm) y } in (hp, snd qm) }; asm qas = foldl (\(tab, mem) (s, (_, t)) -> fpair (enc mem $ nolam (insert s (fst mem) tab) t) \p m' -> let -- Definitions like "t = t;" must be handled with care. { m'' = fpair m' \hp bs -> if p == hp then (hp + 2, bs . (ord 'I':) . (p:)) else m' } in (insert s p tab, m'')) (Tip, (128, id)) qas; -- Type checking. apply sub t = case t of { TC v -> t ; TV v -> maybe t id $ lookup v sub ; TAp a b -> TAp (apply sub a) (apply sub b) }; (@@) s1 s2 = map (second (apply s1)) s2 ++ s1; occurs s t = case t of { TC v -> False ; TV v -> s == v ; TAp a b -> occurs s a || occurs s b }; varBind s t = case t of { TC v -> Just [(s, t)] ; TV v -> Just $ if v == s then [] else [(s, t)] ; TAp a b -> if occurs s t then Nothing else Just [(s, t)] }; charIsInt s = if s == "Char" then "Int" else s; mgu unify t u = case t of { TC a -> case u of { TC b -> if charIsInt a == charIsInt b then Just [] else Nothing ; TV b -> varBind b t ; TAp a b -> Nothing } ; TV a -> varBind a u ; TAp a b -> case u of { TC b -> Nothing ; TV b -> varBind b t ; TAp c d -> unify b d (mgu unify a c) } }; unify a b = maybe Nothing \s -> (@@ s) <$> (mgu unify (apply s a) (apply s b)); --instantiate' :: Type -> Int -> [(String, Type)] -> ((Type, Int), [(String, Type)]) instantiate' t n tab = case t of { TC s -> ((t, n), tab) ; TV s -> case lookup s tab of { Nothing -> let { va = TV (showInt n "") } in ((va, n + 1), (s, va):tab) ; Just v -> ((v, n), tab) } ; TAp x y -> fpair (instantiate' x n tab) \(t1, n1) tab1 -> fpair (instantiate' y n1 tab1) \(t2, n2) tab2 -> ((TAp t1 t2, n2), tab2) }; instantiatePred (Pred s t) ((out, n), tab) = first (first ((:out) . Pred s)) (instantiate' t n tab); --instantiate :: Qual -> Int -> (Qual, Int) instantiate (Qual ps t) n = fpair (foldr instantiatePred (([], n), []) ps) \(ps1, n1) tab -> first (Qual ps1) (fst (instantiate' t n1 tab)); --type SymTab = [(String, (Qual, Ast))]; --type Subst = [(String, Type)]; singleOut s cs = \scrutinee x -> foldl A (A (V $ specialCase cs) scrutinee) $ map (\(Constr s' ts) -> if s == s' then x else foldr L (V "pjoin#") $ map (const "_") ts) cs; unpat dcs n as t = case as of { [] -> (t, n) ; a:at -> let { freshv = showInt n "#" } in first (L freshv) $ let { go n p x = case p of { PatPred pre -> unpat dcs (n + 1) at $ A (A (A pre $ V freshv) x) $ V "pjoin#" ; PatVar s m -> maybe (unpat dcs (n + 1) at) (\p1 x1 -> go (n + 1) p1 x1) m $ beta s (V freshv) x ; PatCon con args -> case mlookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> fpair (unpat dcs (n + 1) args x) \y n1 -> unpat dcs n1 at $ singleOut con cons (V freshv) y } } } in go n a t }; unpatTop dcs n als x = case als of { [] -> (x, n) ; (a, l):alt -> let { go p t = case p of { PatPred pre -> unpatTop dcs n alt $ A (A (A pre $ V l) t) $ V "pjoin#" ; PatVar s m -> maybe (unpatTop dcs n alt) go m $ beta s (V l) t ; PatCon con args -> case mlookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> fpair (unpat dcs n args t) \y n1 -> unpatTop dcs n1 alt $ singleOut con cons (V l) y } } } in go a x }; rewriteGuard join gs = foldr (\(cond, x) acc -> case cond of { V "True" -> x ; _ -> A (A (A (V "if") cond) x) acc }) (V join) gs; rewritePats' dcs asxs ls n = case asxs of { [] -> (V "fail#", n) ; (as, gs):asxt -> fpair (unpatTop dcs n (zip as ls) $ rewriteGuard "pjoin#" gs) \y n1 -> first (A $ L "pjoin#" y) $ rewritePats' dcs asxt ls n1 }; rewritePats dcs vsxs@((vs0, _):_) n = let { ls = map (flip showInt "#") $ take (length vs0) $ upFrom n } in first (flip (foldr L) ls) $ rewritePats' dcs vsxs ls $ n + length ls; classifyAlt v x = case v of { PatPred pre -> Left $ A (A (A pre $ V "of") x) ; PatVar s m -> maybe (Left . A . L "pjoin#") classifyAlt m $ A (L s x) $ V "of" ; PatCon s ps -> Right (insertWith (flip (.)) s ((ps, [(V "True", x)]):)) }; genCase dcs tab = if size tab == 0 then id else A . L "cjoin#" $ let { firstC = flst (toAscList tab) undefined (\h _ -> fst h) ; cs = maybe (error $ "bad constructor: " ++ firstC) id $ mlookup firstC dcs } in foldl A (A (V $ specialCase cs) (V "of")) $ map (\(Constr s ts) -> case mlookup s tab of { Nothing -> foldr L (V "cjoin#") $ const "_" <$> ts ; Just f -> Pa $ f [(const (PatVar "_" Nothing) <$> ts, [(V "True", V "cjoin#")])] }) cs; updateCaseSt dcs (acc, tab) alt = case alt of { Left f -> (acc . genCase dcs tab . f, Tip) ; Right upd -> (acc, upd tab) }; rewriteCase dcs as = fpair (foldl (updateCaseSt dcs) (id, Tip) $ uncurry classifyAlt . second (rewriteGuard "cjoin#") <$> as) \acc tab -> acc . genCase dcs tab $ V "fail#"; --infer :: AdtTab -> SymTab -> Subst -> Ast -> (Maybe Subst, Int) -> ((Type, Ast), (Maybe Subst, Int)) infer dcs typed loc ast csn = fpair csn \cs n -> let { va = TV (showInt n "") ; insta ty = fpair (instantiate ty n) \(Qual preds ty) n1 -> ((ty, foldl A ast (map (E . Proof) preds)), (cs, n1)) } in case ast of { E x -> case x of { Basic b -> if b == ord 'Y' then insta $ noQual $ arr (arr (TV "a") (TV "a")) (TV "a") else undefined ; Const c -> ((TC "Int", ast), csn) ; StrCon _ -> ((TAp (TC "[]") (TC "Int"), ast), csn) ; Proof _ -> undefined } ; V s -> fmaybe (lookup s loc) (fmaybe (lookup s typed) (error $ "bad symbol: " ++ s) $ insta . fst) ((, csn) . (, ast)) ; A x y -> fpair (infer dcs typed loc x (cs, n + 1)) \(tx, ax) csn1 -> fpair (infer dcs typed loc y csn1) \(ty, ay) csn2 -> ((va, A ax ay), first (unify tx (arr ty va)) csn2) ; L s x -> first (\ta -> fpair ta \t a -> (arr va t, L s a)) (infer dcs typed ((s, va):loc) x (cs, n + 1)) ; Pa vsxs -> fpair (rewritePats dcs vsxs n) \re n1 -> infer dcs typed loc re (cs, n1) ; Ca x as -> infer dcs typed loc (A (L "of" $ rewriteCase dcs as) x) csn }; onType f pred = case pred of { Pred s t -> Pred s (f t) }; instance Eq Type where { (TC s) == (TC t) = s == t ; (TV s) == (TV t) = s == t ; (TAp a b) == (TAp c d) = a == c && b == d ; _ == _ = False }; instance Eq Pred where { (Pred s a) == (Pred t b) = s == t && a == b }; predApply sub p = onType (apply sub) p; filter f = foldr (\x xs -> if f x then x:xs else xs) []; intersect xs ys = filter (\x -> fmaybe (find (x ==) ys) False (\_ -> True)) xs; merge s1 s2 = if all (\v -> apply s1 (TV v) == apply s2 (TV v)) $ map fst s1 `intersect` map fst s2 then Just $ s1 ++ s2 else Nothing; match h t = case h of { TC a -> case t of { TC b -> if a == b then Just [] else Nothing ; TV _ -> Nothing ; TAp _ _ -> Nothing } ; TV a -> Just [(a, t)] ; TAp a b -> case t of { TC _ -> Nothing ; TV _ -> Nothing ; TAp c d -> case match a c of { Nothing -> Nothing ; Just ac -> case match b d of { Nothing -> Nothing ; Just bd -> merge ac bd } } } }; matchPred h (Pred _ t) = match h t; showType t = case t of { TC s -> s ; TV s -> s ; TAp a b -> concat ["(", showType a, " ", showType b, ")"] }; showPred (Pred s t) = s ++ (' ':showType t) ++ " => "; findInst r qn p insts = case insts of { [] -> fpair qn \q n -> let { v = '*':showInt n "" } in (((p, v):q, n + 1), V v) ; (Qual ps h):is -> case matchPred h p of { Nothing -> findInst r qn p is ; Just u -> foldl (\(qn1, t) p -> second (A t) (r (predApply u p) qn1)) (qn, V (case p of { Pred s _ -> showPred $ Pred s h})) ps }}; findProof ienv pred psn@(ps, n) = case lookup pred ps of { Nothing -> case pred of { Pred s t -> case mlookup s ienv of { Nothing -> error $ "no instances: " ++ s ; Just insts -> findInst (findProof ienv) psn pred insts }} ; Just s -> (psn, V s) }; prove' ienv sub psn a = case a of { E (Proof raw) -> findProof ienv (predApply sub raw) psn ; A x y -> fpair (prove' ienv sub psn x) \psn1 x1 -> second (A x1) (prove' ienv sub psn1 y) ; L s t -> second (L s) (prove' ienv sub psn t) ; _ -> (psn, a) }; --prove :: [(String, [Qual])] -> (Type, Ast) -> Subst -> (Qual, Ast) prove ienv s (t, a) sub = fpair (prove' ienv sub ([], 0) a) \(ps, _) x -> let { applyDicts expr = foldl A expr $ map (V . snd) ps } in (Qual (map fst ps) (apply sub t), foldr L (overFree s applyDicts x) $ map snd ps); dictVars ps n = flst ps ([], n) \p pt -> first ((p, '*':showInt n ""):) (dictVars pt $ n + 1); -- The 4th argument is Qual of the instance, e.g. Eq t => [t] -> [t] -> Bool inferMethod ienv dcs typed (Qual psi ti) def = fpair def \s expr -> fpair (infer dcs typed [] expr (Just [], 0)) \ta (ms, n) -> case lookup s typed of { Nothing -> error $ "no such method: " ++ s -- e.g. qac = Eq a => a -> a -> Bool, some AST (product of single method) ; Just qac -> case ms of { Nothing -> error "method: type mismatch" ; Just sub -> fpair (instantiate (fst qac) n) \(Qual [Pred _ headT] tc) n1 -> case match headT ti of { Nothing -> undefined -- e.g. Eq t => [t] -> [t] -> Bool -- instantiate and match it against type of ta ; Just subc -> fpair (instantiate (Qual psi $ apply subc tc) n1) \(Qual ps2 t2) n2 -> fpair ta \tx ax -> case match (apply sub tx) t2 of { Nothing -> error "class/instance type conflict" ; Just subx -> snd $ prove' ienv (subx @@ sub) (dictVars ps2 0) ax }}}}; inferInst ienv dcs typed inst = fpair inst \cl qds -> fpair qds \q ds -> case q of { Qual ps t -> let { s = showPred $ Pred cl t } in (s, (,) (noQual $ TC "DICT") $ foldr L (L "@" $ foldl A (V "@") (map (inferMethod ienv dcs typed q) ds)) (map snd $ fst $ dictVars ps 0)) }; reverse = foldl (flip (:)) []; inferDefs ienv defs dcs typed = flst defs (Right $ reverse typed) \edef rest -> case edef of { Left (s, expr) -> fpair (infer dcs typed [(s, TV "self!")] expr (Just [], 0)) \ta (ms, _) -> case prove ienv s ta <$> (unify (TV "self!") (fst ta) ms) of { Nothing -> Left ("bad type: " ++ s) ; Just qa -> inferDefs ienv rest dcs ((s, qa):typed) } ; Right inst -> inferDefs ienv rest dcs (inferInst ienv dcs typed inst:typed) }; showQual (Qual ps t) = concatMap showPred ps ++ showType t; untangle = foldr ($) (Neat Tip [] prims Tip [] []); dumpTypes s = fmaybe (program s) "parse error" \(prog, rest) -> fneat (untangle prog) \ienv fs typed dcs ffis exs -> case inferDefs ienv fs dcs typed of { Left err -> err ; Right typed -> concatMap (\(s, (q, _)) -> s ++ " :: " ++ showQual q ++ "\n") typed }; last' x xt = flst xt x \y yt -> last' y yt; last xs = flst xs undefined last'; init (x:xt) = flst xt [] \_ _ -> x : init xt; intercalate sep xs = flst xs [] \x xt -> x ++ concatMap (sep ++) xt; argList t = case t of { TC s -> [TC s] ; TV s -> [TV s] ; TAp (TC "IO") (TC u) -> [TC u] ; TAp (TAp (TC "->") x) y -> x : argList y }; cTypeName (TC "()") = "void"; cTypeName (TC "Int") = "int"; cTypeName (TC "Char") = "int"; ffiDeclare (name, t) = let { tys = argList t } in concat [cTypeName $ last tys, " ", name, "(", intercalate "," $ cTypeName <$> init tys, ");\n"]; ffiArgs n t = case t of { TC s -> ("", ((True, s), n)) ; TAp (TC "IO") (TC u) -> ("", ((False, u), n)) ; TAp (TAp (TC "->") x) y -> first ((ife (3 <= n) ", " "" ++ "num(" ++ showInt n ")") ++) $ ffiArgs (n + 1) y }; ffiDefine n ffis = case ffis of { [] -> id ; (name, t):xt -> fpair (ffiArgs 2 t) \args ((isPure, ret), count) -> let { lazyn = ("lazy(" ++) . showInt (if isPure then count - 1 else count + 1) . (", " ++) ; aa tgt = "app(arg(" ++ showInt (count + 1) "), " ++ tgt ++ "), arg(" ++ showInt count ")" ; longDistanceCall = name ++ "(" ++ args ++ ")" } in ("case " ++) . showInt n . (": " ++) . if ret == "()" then (longDistanceCall ++) . (';':) . lazyn . ((ife isPure "'I', 'K'" (aa "'K'") ++ "); break;") ++) . ffiDefine (n - 1) xt else lazyn . ((ife isPure ("'#', " ++ longDistanceCall) (aa $ "app('#', " ++ longDistanceCall ++ ")") ++ "); break;") ++) . ffiDefine (n - 1) xt }; getContents = getChar >>= \n -> if n <= 255 then (chr n:) <$> getContents else pure []; genMain n = "int main(int argc,char**argv){env_argc=argc;env_argv=argv;rts_init();rts_reduce(" ++ showInt n ");return 0;}\n"; compile s = fmaybe (program s) "parse error" \(prog, rest) -> fneat (untangle prog) \ienv fs typed dcs ffis exs -> case inferDefs ienv fs dcs typed of { Left err -> err ; Right qas -> fpair (asm qas) \tab mem -> (concatMap ffiDeclare ffis ++) . ("static void foreign(u n) {\n switch(n) {\n" ++) . ffiDefine (length ffis - 1) ffis . ("\n }\n}\n" ++) . ("static const u prog[]={" ++) . foldr (.) id (map (\n -> showInt n . (',':)) $ snd mem []) . ("};\nstatic const u prog_size=sizeof(prog)/sizeof(*prog);\n" ++) . ("static u root[]={" ++) . foldr (\(x, y) f -> maybe undefined showInt (mlookup y tab) . (", " ++) . f) id exs . ("};\n" ++) . ("static const u root_size=" ++) . showInt (length exs) . (";\n" ++) $ (foldr (.) id $ zipWith (\p n -> (("EXPORT(f" ++ showInt n ", \"" ++ fst p ++ "\", " ++ showInt n ")\n") ++)) exs (upFrom 0)) $ maybe "" genMain (mlookup "main" tab) }; main = getContents >>= putStr . compile;
Assembly
We split off rewriting cases and patterns into a separate function, and change it from top-down to bottom-up.
We split off and delay address lookup for symbols from bracket abstraction, and also delay converting literals to combinators as late as possible.
All this slows our compiler and adds more lines of code, but it disentangles various phases of the pipeline.
The refactoring makes it easy to dump the output of bracket abstraction on the source code, which is somewhat analogous to a typical compiler printing the assembly it generates.
We add support for quasiquoted raw strings; see the raw-strings-qq package.
-- Disassembler. infixr 9 .; infixl 7 * , / , %; infixl 6 + , -; infixr 5 ++; infixl 4 <*> , <$> , <* , *>; infix 4 == , /= , <=; infixl 3 && , <|>; infixl 2 ||; infixl 1 >> , >>=; infixr 0 $; ffi "putchar" putChar :: Int -> IO Int; ffi "getchar" getChar :: IO Int; ffi "getargcount" getArgCount :: IO Int; ffi "getargchar" getArgChar :: Int -> Int -> IO Char; class Functor f where { fmap :: (a -> b) -> f a -> f b }; class Applicative f where { pure :: a -> f a ; (<*>) :: f (a -> b) -> f a -> f b }; class Monad m where { return :: a -> m a ; (>>=) :: m a -> (a -> m b) -> m b }; (<$>) = fmap; liftA2 f x y = f <$> x <*> y; (>>) f g = f >>= \_ -> g; class Eq a where { (==) :: a -> a -> Bool }; instance Eq Int where { (==) = intEq }; instance Eq Char where { (==) = charEq }; ($) f x = f x; id x = x; const x y = x; flip f x y = f y x; (&) x f = f x; class Ord a where { (<=) :: a -> a -> Bool }; instance Ord Int where { (<=) = intLE }; instance Ord Char where { (<=) = charLE }; data Ordering = LT | GT | EQ; compare x y = if x <= y then if y <= x then EQ else LT else GT; instance Ord a => Ord [a] where { (<=) xs ys = case xs of { [] -> True ; x:xt -> case ys of { [] -> False ; y:yt -> case compare x y of { LT -> True ; GT -> False ; EQ -> xt <= yt } } } }; data Maybe a = Nothing | Just a; data Either a b = Left a | Right b; fpair (x, y) f = f x y; fst (x, y) = x; snd (x, y) = y; uncurry f (x, y) = f x y; first f (x, y) = (f x, y); second f (x, y) = (x, f y); not a = if a then False else True; x /= y = not $ x == y; (.) f g x = f (g x); (||) f g = if f then True else g; (&&) f g = if f then g else False; flst xs n c = case xs of { [] -> n; h:t -> c h t }; instance Eq a => Eq [a] where { (==) xs ys = case xs of { [] -> case ys of { [] -> True ; _ -> False } ; x:xt -> case ys of { [] -> False ; y:yt -> x == y && xt == yt } }}; take n xs = if n == 0 then [] else flst xs [] \h t -> h:take (n - 1) t; maybe n j m = case m of { Nothing -> n; Just x -> j x }; fmaybe m n j = case m of { Nothing -> n; Just x -> j x }; instance Functor Maybe where { fmap f = maybe Nothing (Just . f) }; instance Applicative Maybe where { pure = Just ; mf <*> mx = maybe Nothing (\f -> maybe Nothing (Just . f) mx) mf }; instance Monad Maybe where { return = Just ; mf >>= mg = maybe Nothing mg mf }; foldr c n l = flst l n (\h t -> c h(foldr c n t)); length = foldr (\_ n -> n + 1) 0; mapM f = foldr (\a rest -> liftA2 (:) (f a) rest) (pure []); mapM_ f = foldr ((>>) . f) (pure ()); foldM f z0 xs = foldr (\x k z -> f z x >>= k) pure xs z0; instance Applicative IO where { pure = ioPure ; (<*>) f x = ioBind f \g -> ioBind x \y -> ioPure (g y) }; instance Monad IO where { return = ioPure ; (>>=) = ioBind }; instance Functor IO where { fmap f x = ioPure f <*> x }; putStr = mapM_ $ putChar . ord; error s = unsafePerformIO $ putStr s >> putChar (ord '\n') >> exitSuccess; undefined = error "undefined"; foldr1 c l@(h:t) = maybe undefined id $ foldr (\x m -> Just $ maybe x (c x) m) Nothing l; foldl f a bs = foldr (\b g x -> g (f x b)) (\x -> x) bs a; foldl1 f (h:t) = foldl f h t; elem k xs = foldr (\x t -> x == k || t) False xs; find f xs = foldr (\x t -> if f x then Just x else t) Nothing xs; (++) = flip (foldr (:)); concat = foldr (++) []; wrap c = c:[]; map = flip (foldr . ((:) .)) []; instance Functor [] where { fmap = map }; concatMap = (concat .) . map; lookup s = foldr (\(k, v) t -> if s == k then Just v else t) Nothing; all f = foldr (&&) True . map f; any f = foldr (||) False . map f; upFrom n = n : upFrom (n + 1); zipWith f xs ys = flst xs [] $ \x xt -> flst ys [] $ \y yt -> f x y : zipWith f xt yt; zip = zipWith (,); data State s a = State (s -> (a, s)); runState (State f) = f; instance Functor (State s) where { fmap f = \(State h) -> State (first f . h) }; instance Applicative (State s) where { pure a = State (a,) ; (State f) <*> (State x) = State \s -> fpair (f s) \g s' -> first g $ x s' }; instance Monad (State s) where { return a = State (a,) ; (State h) >>= f = State $ uncurry (runState . f) . h }; evalState m s = fst $ runState m s; get = State \s -> (s, s); put n = State \s -> ((), n); either l r e = case e of { Left x -> l x; Right x -> r x }; instance Functor (Either a) where { fmap f e = case e of { Left x -> Left x ; Right x -> Right $ f x } }; instance Applicative (Either a) where { pure = Right ; ef <*> ex = case ef of { Left s -> Left s ; Right f -> case ex of { Left s -> Left s ; Right x -> Right $ f x } } }; instance Monad (Either a) where { return = Right ; ex >>= f = case ex of { Left s -> Left s ; Right x -> f x } }; -- Map. data Map k a = Tip | Bin Int k a (Map k a) (Map k a); size m = case m of { Tip -> 0 ; Bin sz _ _ _ _ -> sz }; node k x l r = Bin (1 + size l + size r) k x l r; singleton k x = Bin 1 k x Tip Tip; singleL k x l (Bin _ rk rkx rl rr) = node rk rkx (node k x l rl) rr; doubleL k x l (Bin _ rk rkx (Bin _ rlk rlkx rll rlr) rr) = node rlk rlkx (node k x l rll) (node rk rkx rlr rr); singleR k x (Bin _ lk lkx ll lr) r = node lk lkx ll (node k x lr r); doubleR k x (Bin _ lk lkx ll (Bin _ lrk lrkx lrl lrr)) r = node lrk lrkx (node lk lkx ll lrl) (node k x lrr r); balance k x l r = (if size l + size r <= 1 then node else if 5 * size l + 3 <= 2 * size r then case r of { Tip -> node ; Bin sz _ _ rl rr -> if 2 * size rl + 1 <= 3 * size rr then singleL else doubleL } else if 5 * size r + 3 <= 2 * size l then case l of { Tip -> node ; Bin sz _ _ ll lr -> if 2 * size lr + 1 <= 3 * size ll then singleR else doubleR } else node ) k x l r; insert kx x t = case t of { Tip -> singleton kx x ; Bin sz ky y l r -> case compare kx ky of { LT -> balance ky y (insert kx x l) r ; GT -> balance ky y l (insert kx x r) ; EQ -> Bin sz kx x l r } }; insertWith f kx x t = case t of { Tip -> singleton kx x ; Bin sy ky y l r -> case compare kx ky of { LT -> balance ky y (insertWith f kx x l) r ; GT -> balance ky y l (insertWith f kx x r) ; EQ -> Bin sy kx (f x y) l r } }; mlookup kx t = case t of { Tip -> Nothing ; Bin _ ky y l r -> case compare kx ky of { LT -> mlookup kx l ; GT -> mlookup kx r ; EQ -> Just y } }; fromList = foldl (\t (k, x) -> insert k x t) Tip; foldrWithKey f = let { go z t = case t of { Tip -> z ; Bin _ kx x l r -> go (f kx x (go z r)) l } } in go; toAscList = foldrWithKey (\k x xs -> (k,x):xs) []; -- Parsing. data Type = TC String | TV String | TAp Type Type; arr a b = TAp (TAp (TC "->") a) b; data Extra = Basic Char | Const Int | ChrCon Char | StrCon String; data Pat = PatLit Extra | PatVar String (Maybe Pat) | PatCon String [Pat]; data Ast = E Extra | V String | A Ast Ast | L String Ast | Pa [([Pat], Ast)] | Ca Ast [(Pat, Ast)] | Proof Pred; data Parser a = Parser (String -> Maybe (a, String)); data Constr = Constr String [Type]; data Pred = Pred String Type; data Qual = Qual [Pred] Type; noQual = Qual []; data Neat = Neat -- | Instance environment. (Map String [Qual]) -- | Either top-level or instance definitions. [Either (String, Ast) (String, (Qual, [(String, Ast)]))] -- | Typed ASTs, ready for compilation, including ADTs and methods, -- e.g. (==), (Eq a => a -> a -> Bool, select-==) [(String, (Qual, Ast))] -- | Data constructor table. (Map String [Constr]) -- | FFI declarations. [(String, Type)] -- | Exports. [(String, String)] ; fneat (Neat a b c d e f) z = z a b c d e f; ro = E . Basic; conOf (Constr s _) = s; specialCase (h:_) = '|':conOf h; mkCase t cs = (specialCase cs, ( noQual $ arr t $ foldr arr (TV "case") $ map (\(Constr _ ts) -> foldr arr (TV "case") ts) cs , ro 'I')); mkStrs = snd . foldl (\(s, l) u -> ('*':s, s:l)) ("*", []); scottEncode _ ":" _ = ro ':'; scottEncode vs s ts = foldr L (foldl (\a b -> A a (V b)) (V s) ts) (ts ++ vs); scottConstr t cs c = case c of { Constr s ts -> (s, ( noQual $ foldr arr t ts , scottEncode (map conOf cs) s $ mkStrs ts)) }; mkAdtDefs t cs = mkCase t cs : map (scottConstr t cs) cs; showInt' n = if 0 == n then id else (showInt' $ n/10) . ((:) (chr $ 48+n%10)); showInt n = if 0 == n then ('0':) else showInt' n; mkFFIHelper n t acc = case t of { TC s -> acc ; TAp (TC "IO") _ -> acc ; TAp (TAp (TC "->") x) y -> L (showInt n "") $ mkFFIHelper (n + 1) y $ A (V $ showInt n "") acc }; updateDcs cs dcs = foldr (\(Constr s _) m -> insert s cs m) dcs cs; addAdt t cs (Neat ienv fs typed dcs ffis exs) = Neat ienv fs (mkAdtDefs t cs ++ typed) (updateDcs cs dcs) ffis exs; addClass classId v ms (Neat ienv fs typed dcs ffis exs) = let { vars = zipWith (\_ n -> showInt n "") ms $ upFrom 0 } in Neat ienv fs (zipWith (\var (s, t) -> (s, (Qual [Pred classId v] t, L "@" $ A (V "@") $ foldr L (V var) vars))) vars ms ++ typed) dcs ffis exs; addInst cl q ds (Neat ienv fs typed dcs ffis exs) = Neat (insertWith (++) cl [q] ienv) (Right (cl, (q, ds)):fs) typed dcs ffis exs; addFFI foreignname ourname t (Neat ienv fs typed dcs ffis exs) = Neat ienv fs ((ourname, (Qual [] t, mkFFIHelper 0 t $ A (ro 'F') (ro $ chr $ length ffis))) : typed) dcs ((foreignname, t):ffis) exs; addDefs ds (Neat ienv fs typed dcs ffis exs) = Neat ienv (map Left ds ++ fs) typed dcs ffis exs; addExport e f (Neat ienv fs typed dcs ffis exs) = Neat ienv fs typed dcs ffis ((e, f):exs); parse (Parser f) inp = f inp; instance Applicative Parser where { pure x = Parser \inp -> Just (x, inp) ; (<*>) x y = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just (fun, t) -> case parse y t of { Nothing -> Nothing ; Just (arg, u) -> Just (fun arg, u) } } }; instance Monad Parser where { return = pure ; (>>=) x f = Parser \inp -> case parse x inp of { Nothing -> Nothing ; Just (a, t) -> parse (f a) t } }; sat' f = \h t -> if f h then Just (h, t) else Nothing; sat f = Parser \inp -> flst inp Nothing (sat' f); instance Functor Parser where { fmap f x = pure f <*> x }; (<|>) x y = Parser \inp -> fmaybe (parse x inp) (parse y inp) Just; (*>) = liftA2 \x y -> y; (<*) = liftA2 \x y -> x; many p = liftA2 (:) p (many p) <|> pure []; some p = liftA2 (:) p (many p); sepBy1 p sep = liftA2 (:) p (many (sep *> p)); sepBy p sep = sepBy1 p sep <|> pure []; char c = sat (c ==); between x y p = x *> (p <* y); com = char '-' *> between (char '-') (char '\n') (many $ sat ('\n' /=)); sp = many ((wrap <$> (sat (\c -> (c == ' ') || (c == '\n')))) <|> com); spc f = f <* sp; spch = spc . char; wantWith pred f = Parser \inp -> case parse f inp of { Nothing -> Nothing ; Just at -> if pred $ fst at then Just at else Nothing }; paren = between (spch '(') (spch ')'); small = sat \x -> ((x <= 'z') && ('a' <= x)) || (x == '_'); large = sat \x -> (x <= 'Z') && ('A' <= x); digit = sat \x -> (x <= '9') && ('0' <= x); symbo = sat \c -> elem c "!#$%&*+./<=>?@\\^|-~"; varLex = liftA2 (:) small (many (small <|> large <|> digit <|> char '\'')); conId = spc (liftA2 (:) large (many (small <|> large <|> digit <|> char '\''))); varId = spc $ wantWith (\s -> not $ elem s ["class", "data", "instance", "of", "where", "if", "then", "else"]) varLex; opTail = many $ char ':' <|> symbo; conSym = spc $ liftA2 (:) (char ':') opTail; varSym = spc $ wantWith (not . (`elem` ["@", "=", "|", "->", "=>"])) $ liftA2 (:) symbo opTail; con = conId <|> paren conSym; var = varId <|> paren varSym; op = varSym <|> conSym <|> between (spch '`') (spch '`') (conId <|> varId); conop = conSym <|> between (spch '`') (spch '`') conId; escChar = char '\\' *> ((sat (\c -> elem c "'\"\\")) <|> ((\c -> '\n') <$> char 'n')); litOne delim = escChar <|> sat (delim /=); litInt = Const . foldl (\n d -> 10*n + ord d - ord '0') 0 <$> spc (some digit); litChar = ChrCon <$> between (char '\'') (spch '\'') (litOne '\''); litStr = between (char '"') (spch '"') $ many (litOne '"'); lit = StrCon <$> litStr <|> litChar <|> litInt; sqLst r = between (spch '[') (spch ']') $ sepBy r (spch ','); want f s = wantWith (s ==) f; tok s = spc $ want (some (char '_' <|> symbo) <|> varLex) s; gcon = conId <|> paren (conSym <|> (wrap <$> spch ',')) <|> ((:) <$> spch '[' <*> (wrap <$> spch ']')); apat' r = PatVar <$> var <*> (tok "@" *> (Just <$> apat' r) <|> pure Nothing) <|> flip PatCon [] <$> gcon <|> PatLit <$> lit <|> foldr (\h t -> PatCon ":" [h, t]) (PatCon "[]" []) <$> sqLst r <|> paren ((&) <$> r <*> ((spch ',' *> ((\y x -> PatCon "," [x, y]) <$> r)) <|> pure id)) ; pat = PatCon <$> gcon <*> many (apat' pat) <|> (&) <$> apat' pat <*> ((\s r l -> PatCon s [l, r]) <$> conop <*> apat' pat <|> pure id); apat = apat' pat; guards s r = tok s *> r <|> foldr ($) (V "pjoin#") <$> some ((\x y -> case x of { V "True" -> \_ -> y ; _ -> A (A (A (V "if") x) y) }) <$> (spch '|' *> r) <*> (tok s *> r)); alt r = (,) <$> pat <*> guards "->" r; braceSep f = between (spch '{') (spch '}') (sepBy f (spch ';')); alts r = braceSep (alt r); cas r = Ca <$> between (tok "case") (tok "of") r <*> alts r; lamCase r = tok "case" *> (L "@" . Ca (V "@") <$> alts r); onePat vs x = Pa [(vs, x)]; lam r = spch '\\' *> (lamCase r <|> liftA2 onePat (some apat) (tok "->" *> r)); flipPairize y x = A (A (V ",") x) y; thenComma r = spch ',' *> ((flipPairize <$> r) <|> pure (A (V ","))); parenExpr r = (&) <$> r <*> (((\v a -> A (V v) a) <$> op) <|> thenComma r <|> pure id); rightSect r = ((\v a -> L "@" $ A (A (V v) $ V "@") a) <$> (op <|> (wrap <$> spch ','))) <*> r; section r = spch '(' *> (parenExpr r <* spch ')' <|> rightSect r <* spch ')' <|> spch ')' *> pure (V "()")); isFreePat v = \case { PatLit _ -> False ; PatVar s m -> s == v || maybe False (isFreePat v) m ; PatCon _ args -> any (isFreePat v) args }; isFree v expr = case expr of { E _ -> False ; V s -> s == v ; A x y -> isFree v x || isFree v y ; L w t -> v /= w && isFree v t ; Pa vsts -> any (\(vs, t) -> not (any (isFreePat v) vs) && isFree v t) vsts ; Ca x as -> isFree v x || isFree v (Pa $ first (:[]) <$> as) }; overFree s f t = case t of { E _ -> t ; V s' -> if s == s' then f t else t ; A x y -> A (overFree s f x) (overFree s f y) ; L s' t' -> if s == s' then t else L s' $ overFree s f t' }; beta s t x = overFree s (const t) x; maybeFix s x = if isFree s x then A (ro 'Y') (L s x) else x; opDef x f y rhs = (f, onePat [x, y] rhs); coalesce ds = flst ds [] \h@(s, x) t -> flst t [h] \(s', x') t' -> let { f (Pa vsts) (Pa vsts') = Pa $ vsts ++ vsts' ; f _ _ = error "bad multidef" } in if s == s' then coalesce $ (s, f x x'):t' else h:coalesce t; def r = opDef <$> apat <*> varSym <*> apat <*> guards "=" r <|> liftA2 (,) var (liftA2 onePat (many apat) (guards "=" r)); addLets ls x = foldr (\(name, def) t -> A (L name t) $ maybeFix name def) x ls; letin r = addLets <$> between (tok "let") (tok "in") (coalesce <$> braceSep (def r)) <*> r; ifthenelse r = (\a b c -> A (A (A (V "if") a) b) c) <$> (tok "if" *> r) <*> (tok "then" *> r) <*> (tok "else" *> r); listify = foldr (\h t -> A (A (V ":") h) t) (V "[]"); anyChar = sat \_ -> True; rawBody = (char '|' *> char ']' *> pure []) <|> (:) <$> anyChar <*> rawBody; rawQQ = spc $ char '[' *> char 'r' *> char '|' *> (E . StrCon <$> rawBody); atom r = ifthenelse r <|> letin r <|> rawQQ <|> listify <$> sqLst r <|> section r <|> cas r <|> lam r <|> (paren (spch ',') *> pure (V ",")) <|> fmap V (con <|> var) <|> E <$> lit; aexp r = fmap (foldl1 A) (some (atom r)); fix f = f (fix f); data Assoc = NAssoc | LAssoc | RAssoc; instance Eq Assoc where { NAssoc == NAssoc = True ; LAssoc == LAssoc = True ; RAssoc == RAssoc = True ; _ == _ = False }; precOf s precTab = fmaybe (lookup s precTab) 9 fst; assocOf s precTab = fmaybe (lookup s precTab) LAssoc snd; opWithPrec precTab n = wantWith (\s -> n == precOf s precTab) op; opFold precTab e xs = case xs of { [] -> e ; x:xt -> case find (\y -> assocOf (fst x) precTab /= assocOf (fst y) precTab) xt of { Nothing -> case assocOf (fst x) precTab of { NAssoc -> case xt of { [] -> fpair x (\op y -> A (A (V op) e) y) ; y:yt -> undefined } ; LAssoc -> foldl (\a (op, y) -> A (A (V op) a) y) e xs ; RAssoc -> foldr (\(op, y) b -> \e -> A (A (V op) e) (b y)) id xs $ e } ; Just y -> undefined } }; expr precTab = fix \r n -> if n <= 9 then liftA2 (opFold precTab) (r $ succ n) (many (liftA2 (,) (opWithPrec precTab n) (r $ succ n))) else aexp (r 0); bType r = foldl1 TAp <$> some r; _type r = foldr1 arr <$> sepBy (bType r) (spc (tok "->")); typeConst = (\s -> if s == "String" then TAp (TC "[]") (TC "Char") else TC s) <$> conId; aType = spch '(' *> (spch ')' *> pure (TC "()") <|> ((&) <$> _type aType <*> ((spch ',' *> ((\a b -> TAp (TAp (TC ",") b) a) <$> _type aType)) <|> pure id)) <* spch ')') <|> typeConst <|> (TV <$> varId) <|> (spch '[' *> (spch ']' *> pure (TC "[]") <|> TAp (TC "[]") <$> (_type aType <* spch ']'))); simpleType c vs = foldl TAp (TC c) (map TV vs); constr = (\x c y -> Constr c [x, y]) <$> aType <*> conSym <*> aType <|> Constr <$> conId <*> many aType; adt = addAdt <$> between (tok "data") (spch '=') (simpleType <$> conId <*> many varId) <*> sepBy constr (spch '|'); prec = (\c -> ord c - ord '0') <$> spc digit; fixityList a n os = map (\o -> (o, (n, a))) os; fixityDecl kw a = between (tok kw) (spch ';') (fixityList a <$> prec <*> sepBy op (spch ',')); fixity = fixityDecl "infix" NAssoc <|> fixityDecl "infixl" LAssoc <|> fixityDecl "infixr" RAssoc; genDecl = (,) <$> var <*> (char ':' *> spch ':' *> _type aType); classDecl = tok "class" *> (addClass <$> conId <*> (TV <$> varId) <*> (tok "where" *> braceSep genDecl)); inst = _type aType; instDecl r = tok "instance" *> ((\ps cl ty defs -> addInst cl (Qual ps ty) defs) <$> (((wrap .) . Pred <$> conId <*> (inst <* tok "=>")) <|> pure []) <*> conId <*> inst <*> (tok "where" *> (coalesce <$> braceSep (def r)))); ffiDecl = tok "ffi" *> (addFFI <$> litStr <*> var <*> (char ':' *> spch ':' *> _type aType)); tops precTab = sepBy ( adt <|> classDecl <|> instDecl (expr precTab 0) <|> ffiDecl <|> addDefs . coalesce <$> sepBy1 (def $ expr precTab 0) (spch ';') <|> tok "export" *> (addExport <$> litStr <*> var) ) (spch ';') <* (spch ';' <|> pure ';'); program = parse $ sp *> (((":", (5, RAssoc)):) . concat <$> many fixity) >>= tops; -- Primitives. primAdts = [ addAdt (TC "()") [Constr "()" []] , addAdt (TC "Bool") [Constr "True" [], Constr "False" []] , addAdt (TAp (TC "[]") (TV "a")) [Constr "[]" [], Constr ":" [TV "a", TAp (TC "[]") (TV "a")]] , addAdt (TAp (TAp (TC ",") (TV "a")) (TV "b")) [Constr "," [TV "a", TV "b"]]]; prims = let { ii = arr (TC "Int") (TC "Int") ; iii = arr (TC "Int") ii ; bin s = A (ro 'Q') (ro s) } in map (second (first noQual)) $ [ ("intEq", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin '=')) , ("intLE", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin 'L')) , ("charEq", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin '=')) , ("charLE", (arr (TC "Char") (arr (TC "Char") (TC "Bool")), bin 'L')) , ("if", (arr (TC "Bool") $ arr (TV "a") $ arr (TV "a") (TV "a"), ro 'I')) , ("chr", (arr (TC "Int") (TC "Char"), ro 'I')) , ("ord", (arr (TC "Char") (TC "Int"), ro 'I')) , ("succ", (ii, A (ro 'T') (A (E $ Const $ 1) (ro '+')))) , ("ioBind", (arr (TAp (TC "IO") (TV "a")) (arr (arr (TV "a") (TAp (TC "IO") (TV "b"))) (TAp (TC "IO") (TV "b"))), ro 'C')) , ("ioPure", (arr (TV "a") (TAp (TC "IO") (TV "a")), A (A (ro 'B') (ro 'C')) (ro 'T'))) , ("exitSuccess", (TAp (TC "IO") (TV "a"), ro '.')) , ("unsafePerformIO", (arr (TAp (TC "IO") (TV "a")) (TV "a"), A (A (ro 'C') (A (ro 'T') (ro '?'))) (ro 'K'))) , ("fail#", (TV "a", A (V "unsafePerformIO") (V "exitSuccess"))) ] ++ map (\s -> (wrap s, (iii, bin s))) "+-*/%"; -- Conversion to De Bruijn indices. data LC = Ze | Su LC | Pass Extra | PassVar String | La LC | App LC LC; debruijn n e = case e of { E x -> Pass x ; V v -> maybe (PassVar v) id $ foldr (\h found -> if h == v then Just Ze else Su <$> found) Nothing n ; A x y -> App (debruijn n x) (debruijn n y) ; L s t -> La (debruijn (s:n) t) }; -- Kiselyov bracket abstraction. data IntTree = Lf Extra | LfVar String | Nd IntTree IntTree; data Sem = Defer | Closed IntTree | Need Sem | Weak Sem; lf = Lf . Basic; ldef = \r y -> case y of { Defer -> Need (Closed (Nd (Nd (lf 'S') (lf 'I')) (lf 'I'))) ; Closed d -> Need (Closed (Nd (lf 'T') d)) ; Need e -> Need (r (Closed (Nd (lf 'S') (lf 'I'))) e) ; Weak e -> Need (r (Closed (lf 'T')) e) }; lclo = \r d y -> case y of { Defer -> Need (Closed d) ; Closed dd -> Closed (Nd d dd) ; Need e -> Need (r (Closed (Nd (lf 'B') d)) e) ; Weak e -> Weak (r (Closed d) e) }; lnee = \r e y -> case y of { Defer -> Need (r (r (Closed (lf 'S')) e) (Closed (lf 'I'))) ; Closed d -> Need (r (Closed (Nd (lf 'R') d)) e) ; Need ee -> Need (r (r (Closed (lf 'S')) e) ee) ; Weak ee -> Need (r (r (Closed (lf 'C')) e) ee) }; lwea = \r e y -> case y of { Defer -> Need e ; Closed d -> Weak (r e (Closed d)) ; Need ee -> Need (r (r (Closed (lf 'B')) e) ee) ; Weak ee -> Weak (r e ee) }; babsa x y = case x of { Defer -> ldef babsa y ; Closed d -> lclo babsa d y ; Need e -> lnee babsa e y ; Weak e -> lwea babsa e y }; babs t = case t of { Ze -> Defer ; Su x -> Weak (babs x) ; Pass x -> Closed (Lf x) ; PassVar s -> Closed (LfVar s) ; La t -> case babs t of { Defer -> Closed (lf 'I') ; Closed d -> Closed (Nd (lf 'K') d) ; Need e -> e ; Weak e -> babsa (Closed (lf 'K')) e } ; App x y -> babsa (babs x) (babs y) }; nolam' x = (\(Closed d) -> d) $ babs $ debruijn [] x; isLeaf t c = case t of { Lf (Basic n) -> n == c ; _ -> False }; optim comtab t = case t of { LfVar s -> let { u = maybe t id $ mlookup s comtab } in case u of { LfVar _ -> u ; Lf (Basic _) -> u ; _ -> t } ; Lf _ -> t ; Nd x y -> let { p = optim comtab x ; q = optim comtab y } in if isLeaf p 'I' then q else if isLeaf q 'I' then case p of { Lf (Basic c) | c == 'C' -> lf 'T' | c == 'B' -> lf 'I' ; Nd p1 p2 -> case p1 of { Lf (Basic c) | c == 'B' -> p2 | c == 'R' -> Nd (lf 'T') p2 ; _ -> Nd (Nd p1 p2) q } ; _ -> Nd p q } else if isLeaf q 'T' then case p of { Nd (Lf (Basic 'B')) (Lf (Basic 'C')) -> lf 'V' ; _ -> Nd p q } else Nd p q }; enc mem t = case t of { Lf d -> case d of { Basic c -> (ord c, mem) ; Const c -> fpair mem \hp bs -> (hp, (hp + 2, bs . (ord '#':) . (c:))) ; ChrCon c -> fpair mem \hp bs -> (hp, (hp + 2, bs . (ord '#':) . (ord c:))) ; StrCon s -> enc mem $ foldr (\h t -> Nd (Nd (lf ':') (Nd (lf '#') (lf h))) t) (lf 'K') s } ; Nd x y -> fpair mem \hp bs -> let { pm qm = enc (hp + 2, bs . (fst (pm qm):) . (fst qm:)) x ; qm = enc (snd $ pm qm) y } in (hp, snd qm) }; freeCount v expr = case expr of { E _ -> 0 ; V s -> if s == v then 1 else 0 ; A x y -> freeCount v x + freeCount v y ; L w t -> if v == w then 0 else freeCount v t }; app01 s x = let { n = freeCount s x } in if 2 <= n then A $ L s x else if 0 == n then const x else flip (beta s) x; optiApp t = case t of { A (L s x) y -> app01 s (optiApp x) (optiApp y) ; A x y -> A (optiApp x) (optiApp y) ; L s x -> L s (optiApp x) ; _ -> t }; nolam lambs = let { comtab = foldl (\m (s, t) -> insert s (optim m $ nolam' $ optiApp t) m) Tip lambs } in map (\(s, _) -> (s, maybe undefined id $ mlookup s comtab)) lambs; resolve tab t = case t of { LfVar s -> maybe undefined (Lf . Basic . chr) $ mlookup s tab ; Lf _ -> t ; Nd x y -> Nd (resolve tab x) (resolve tab y) }; asm lambs = foldl (\(tab, mem) (s, t) -> fpair (enc mem $ resolve (insert s (fst mem) tab) t) \p m' -> let -- Definitions like "t = t;" must be handled with care. { m'' = fpair m' \hp bs -> if p == hp then (hp + 2, bs . (ord 'I':) . (p:)) else m' } in (insert s p tab, m'')) (Tip, (128, id)) $ nolam lambs; -- Type checking. apply sub t = case t of { TC v -> t ; TV v -> maybe t id $ lookup v sub ; TAp a b -> TAp (apply sub a) (apply sub b) }; (@@) s1 s2 = map (second (apply s1)) s2 ++ s1; occurs s t = case t of { TC v -> False ; TV v -> s == v ; TAp a b -> occurs s a || occurs s b }; varBind s t = case t of { TC v -> Just [(s, t)] ; TV v -> Just $ if v == s then [] else [(s, t)] ; TAp a b -> if occurs s t then Nothing else Just [(s, t)] }; mgu unify t u = case t of { TC a -> case u of { TC b -> if a == b then Just [] else Nothing ; TV b -> varBind b t ; TAp a b -> Nothing } ; TV a -> varBind a u ; TAp a b -> case u of { TC b -> Nothing ; TV b -> varBind b t ; TAp c d -> mgu unify a c >>= unify b d } }; unify a b s = (@@ s) <$> mgu unify (apply s a) (apply s b); --instantiate' :: Type -> Int -> [(String, Type)] -> ((Type, Int), [(String, Type)]) instantiate' t n tab = case t of { TC s -> ((t, n), tab) ; TV s -> case lookup s tab of { Nothing -> let { va = TV (showInt n "") } in ((va, n + 1), (s, va):tab) ; Just v -> ((v, n), tab) } ; TAp x y -> fpair (instantiate' x n tab) \(t1, n1) tab1 -> fpair (instantiate' y n1 tab1) \(t2, n2) tab2 -> ((TAp t1 t2, n2), tab2) }; instantiatePred (Pred s t) ((out, n), tab) = first (first ((:out) . Pred s)) (instantiate' t n tab); --instantiate :: Qual -> Int -> (Qual, Int) instantiate (Qual ps t) n = fpair (foldr instantiatePred (([], n), []) ps) \(ps1, n1) tab -> first (Qual ps1) (fst (instantiate' t n1 tab)); proofApply sub a = case a of { Proof (Pred cl ty) -> Proof (Pred cl $ apply sub ty) ; A x y -> A (proofApply sub x) (proofApply sub y) ; L s t -> L s $ proofApply sub t ; _ -> a }; infer' dcs typed loc ast csn = fpair csn \cs n -> let { va = TV (showInt n "") ; insta ty = fpair (instantiate ty n) \(Qual preds ty) n1 -> ((ty, foldl A ast (map Proof preds)), (cs, n1)) } in case ast of { E x -> case x of { Basic 'Y' -> insta $ noQual $ arr (arr (TV "a") (TV "a")) (TV "a") ; Const _ -> ((TC "Int", ast), csn) ; ChrCon _ -> ((TC "Char", ast), csn) ; StrCon _ -> ((TAp (TC "[]") (TC "Char"), ast), csn) } ; V s -> fmaybe (lookup s loc) (fmaybe (mlookup s typed) (error $ "bad symbol: " ++ s) insta) ((, csn) . (, ast)) ; A x y -> fpair (infer' dcs typed loc x (cs, n + 1)) \(tx, ax) csn1 -> fpair (infer' dcs typed loc y csn1) \(ty, ay) csn2 -> ((va, A ax ay), first (maybe (error "unify failed") id . unify tx (arr ty va)) csn2) ; L s x -> first (\(t, a) -> (arr va t, L s a)) $ infer' dcs typed ((s, va):loc) x (cs, n + 1) }; infer dcs typed loc ast = fpair (infer' dcs typed loc ast ([], 0)) \(t, a) (cs, n) -> case unify (TV "self!") t cs of { Just sub -> ((apply sub t, proofApply sub a), n) }; instance Eq Type where { (TC s) == (TC t) = s == t ; (TV s) == (TV t) = s == t ; (TAp a b) == (TAp c d) = a == c && b == d ; _ == _ = False }; instance Eq Pred where { (Pred s a) == (Pred t b) = s == t && a == b }; filter f = foldr (\x xs -> if f x then x:xs else xs) []; intersect xs ys = filter (\x -> fmaybe (find (x ==) ys) False (\_ -> True)) xs; merge s1 s2 = if all (\v -> apply s1 (TV v) == apply s2 (TV v)) $ map fst s1 `intersect` map fst s2 then Just $ s1 ++ s2 else Nothing; match h t = case h of { TC a -> case t of { TC b | a == b -> Just [] ; _ -> Nothing } ; TV a -> Just [(a, t)] ; TAp a b -> case t of { TAp c d -> case match a c of { Nothing -> Nothing ; Just ac -> case match b d of { Nothing -> Nothing ; Just bd -> merge ac bd } } ; _ -> Nothing } }; par f = ('(':) . f . (')':); showType t = case t of { TC s -> (s++) ; TV s -> (s++) ; TAp (TAp (TC "->") a) b -> par $ showType a . (" -> "++) . showType b ; TAp a b -> par $ showType a . (' ':) . showType b }; showPred (Pred s t) = (s++) . (' ':) . showType t . (" => "++); dictVarize s t = '{':s ++ (' ':showType t "") ++ "}"; findInst r qn p@(Pred cl ty) insts = case insts of { [] -> fpair qn \q n -> let { v = '*':showInt n "" } in Right (((p, v):q, n + 1), V v) ; (Qual ps h):is -> case match h ty of { Nothing -> findInst r qn p is ; Just u -> foldM (\(qn1, t) (Pred cl1 ty1) -> second (A t) <$> r (Pred cl1 $ apply u ty1) qn1) (qn, V $ dictVarize cl h) ps }}; findProof ienv pred psn@(ps, n) = case lookup pred ps of { Nothing -> case pred of { Pred s t -> case mlookup s ienv of { Nothing -> Left $ "no instances: " ++ s ; Just insts -> findInst (findProof ienv) psn pred insts }} ; Just s -> Right (psn, V s) }; prove' ienv psn a = case a of { Proof pred -> findProof ienv pred psn ; A x y -> prove' ienv psn x >>= \(psn1, x1) -> second (A x1) <$> prove' ienv psn1 y ; L s t -> second (L s) <$> prove' ienv psn t ; _ -> Right (psn, a) }; dictVars ps n = flst ps ([], n) \p pt -> first ((p, '*':showInt n ""):) (dictVars pt $ n + 1); -- The 4th argument: e.g. Qual [Eq a] "[a]" for Eq a => Eq [a]. inferMethod ienv dcs typed (Qual psi ti) (s, expr) = fpair (infer dcs typed [] expr) \(tx, ax) n -> case mlookup s typed of { Nothing -> Left $ "no such method: " ++ s -- e.g. qc = Eq a => a -> a -> Bool -- We instantiate: Eq a1 => a1 -> a1 -> Bool. ; Just qc -> fpair (instantiate qc n) \(Qual [Pred _ headT] tc) n1 -> -- We mix the predicates `psi` with the type of `headT`, applying a -- substitution such as (a1, [a]) so the variable names match. -- e.g. Eq a => [a] -> [a] -> Bool -- Then instantiate and match. case match headT ti of { Just subc -> fpair (instantiate (Qual psi $ apply subc tc) n1) \(Qual ps2 t2) n2 -> case match tx t2 of { Nothing -> Left "class/instance type conflict" ; Just subx -> snd <$> prove' ienv (dictVars ps2 0) (proofApply subx ax) }}}; inferInst ienv dcs typed (cl, (q@(Qual ps t), ds)) = let { dvs = map snd $ fst $ dictVars ps 0 } in (dictVarize cl t,) . (noQual (TC "DICT"),) . flip (foldr L) dvs . L "@" . foldl A (V "@") <$> mapM (inferMethod ienv dcs typed q) ds; singleOut s cs = \scrutinee x -> foldl A (A (V $ specialCase cs) scrutinee) $ map (\(Constr s' ts) -> if s == s' then x else foldr L (V "pjoin#") $ map (const "_") ts) cs; patEq lit b x y = A (A (A (V "if") (A (A (V "==") (E lit)) b)) x) y; unpat dcs as t = case as of { [] -> pure t ; a:at -> get >>= \n -> put (n + 1) >> let { freshv = showInt n "#" } in L freshv <$> let { go p x = case p of { PatLit lit -> unpat dcs at $ patEq lit (V freshv) x $ V "pjoin#" ; PatVar s m -> maybe (unpat dcs at) (\p1 x1 -> go p1 x1) m $ beta s (V freshv) x ; PatCon con args -> case mlookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> unpat dcs args x >>= \y -> unpat dcs at $ singleOut con cons (V freshv) y } } } in go a t }; unpatTop dcs als x = case als of { [] -> pure x ; (a, l):alt -> let { go p t = case p of { PatLit lit -> unpatTop dcs alt $ patEq lit (V l) t $ V "pjoin#" ; PatVar s m -> maybe (unpatTop dcs alt) go m $ beta s (V l) t ; PatCon con args -> case mlookup con dcs of { Nothing -> error "bad data constructor" ; Just cons -> unpat dcs args t >>= \y -> unpatTop dcs alt $ singleOut con cons (V l) y } } } in go a x }; rewritePats' dcs asxs ls = case asxs of { [] -> pure $ V "fail#" ; (as, t):asxt -> unpatTop dcs (zip as ls) t >>= \y -> A (L "pjoin#" y) <$> rewritePats' dcs asxt ls }; rewritePats dcs vsxs@((vs0, _):_) = get >>= \n -> let { ls = map (flip showInt "#") $ take (length vs0) $ upFrom n } in put (n + length ls) >> flip (foldr L) ls <$> rewritePats' dcs vsxs ls; classifyAlt v x = case v of { PatLit lit -> Left $ patEq lit (V "of") x ; PatVar s m -> maybe (Left . A . L "pjoin#") classifyAlt m $ A (L s x) $ V "of" ; PatCon s ps -> Right (insertWith (flip (.)) s ((ps, x):)) }; genCase dcs tab = if size tab == 0 then id else A . L "cjoin#" $ let { firstC = flst (toAscList tab) undefined (\h _ -> fst h) ; cs = maybe (error $ "bad constructor: " ++ firstC) id $ mlookup firstC dcs } in foldl A (A (V $ specialCase cs) (V "of")) $ map (\(Constr s ts) -> case mlookup s tab of { Nothing -> foldr L (V "cjoin#") $ const "_" <$> ts ; Just f -> Pa $ f [(const (PatVar "_" Nothing) <$> ts, V "cjoin#")] }) cs; updateCaseSt dcs (acc, tab) alt = case alt of { Left f -> (acc . genCase dcs tab . f, Tip) ; Right upd -> (acc, upd tab) }; rewriteCase dcs as = fpair (foldl (updateCaseSt dcs) (id, Tip) $ uncurry classifyAlt <$> as) \acc tab -> acc . genCase dcs tab $ V "fail#"; secondM f (a, b) = (a,) <$> f b; rewritePatterns dcs = let { go t = case t of { E _ -> pure t ; V _ -> pure t ; A x y -> liftA2 A (go x) (go y) ; L s x -> L s <$> go x ; Pa vsxs -> mapM (secondM go) vsxs >>= rewritePats dcs ; Ca x as -> liftA2 A (L "of" . rewriteCase dcs <$> mapM (secondM go) as >>= go) (go x) } } in \case { Left (s, t) -> Left (s, optiApp $ evalState (go t) 0) ; Right (cl, (q, ds)) -> Right (cl, (q, second (\t -> optiApp $ evalState (go t) 0) <$> ds)) }; prove ienv s (t, a) = flip fmap (prove' ienv ([], 0) a) \((ps, _), x) -> let { applyDicts expr = foldl A expr $ map (V . snd) ps } in (s, (Qual (map fst ps) t, foldr L (overFree s applyDicts x) $ map snd ps)); inferDefs' ienv dcs (typeTab, combF) edef = let { add (s, (q, cs)) = (insert s q typeTab, combF . ((s, cs):)) } in add <$> case edef of { Left (s, expr) -> prove ienv s $ fst $ infer dcs typeTab [(s, TV "self!")] expr ; Right inst -> inferInst ienv dcs typeTab inst }; inferDefs ienv defs dcs typed = let { typeTab = foldr (\(k, (q, _)) -> insert k q) Tip typed ; lambs = second snd <$> typed } in foldM (inferDefs' ienv dcs) (typeTab, (lambs++)) $ rewritePatterns dcs <$> defs; last' x xt = flst xt x \y yt -> last' y yt; last xs = flst xs undefined last'; init (x:xt) = flst xt [] \_ _ -> x : init xt; intercalate sep xs = flst xs [] \x xt -> x ++ concatMap (sep ++) xt; argList t = case t of { TC s -> [TC s] ; TV s -> [TV s] ; TAp (TC "IO") (TC u) -> [TC u] ; TAp (TAp (TC "->") x) y -> x : argList y }; cTypeName (TC "()") = "void"; cTypeName (TC "Int") = "int"; cTypeName (TC "Char") = "int"; ffiDeclare (name, t) = let { tys = argList t } in concat [cTypeName $ last tys, " ", name, "(", intercalate "," $ cTypeName <$> init tys, ");\n"]; ffiArgs n t = case t of { TC s -> ("", ((True, s), n)) ; TAp (TC "IO") (TC u) -> ("", ((False, u), n)) ; TAp (TAp (TC "->") x) y -> first (((if 3 <= n then ", " else "") ++ "num(" ++ showInt n ")") ++) $ ffiArgs (n + 1) y }; ffiDefine n ffis = case ffis of { [] -> id ; (name, t):xt -> fpair (ffiArgs 2 t) \args ((isPure, ret), count) -> let { lazyn = ("lazy(" ++) . showInt (if isPure then count - 1 else count + 1) . (", " ++) ; aa tgt = "app(arg(" ++ showInt (count + 1) "), " ++ tgt ++ "), arg(" ++ showInt count ")" ; longDistanceCall = name ++ "(" ++ args ++ ")" } in ("case " ++) . showInt n . (": " ++) . if ret == "()" then (longDistanceCall ++) . (';':) . lazyn . (((if isPure then "'I', 'K'" else aa "'K'") ++ "); break;") ++) . ffiDefine (n - 1) xt else lazyn . (((if isPure then "'#', " ++ longDistanceCall else aa $ "app('#', " ++ longDistanceCall ++ ")") ++ "); break;") ++) . ffiDefine (n - 1) xt }; getContents = getChar >>= \n -> if n <= 255 then (chr n:) <$> getContents else pure []; untangle s = fmaybe (program s) (Left "parse error") \(prog, rest) -> case rest of { "" -> fneat (foldr ($) (Neat Tip [] prims Tip [] []) $ primAdts ++ prog) \ienv fs typed dcs ffis exs -> case inferDefs ienv fs dcs typed of { Left err -> Left err ; Right qas -> Right (qas, (ffis, exs)) } ; s -> Left $ "dregs: " ++ s }; genMain n = "int main(int argc,char**argv){env_argc=argc;env_argv=argv;rts_init();rts_reduce(" ++ showInt n ");return 0;}\n"; compile s = case untangle s of { Left err -> err ; Right ((_, lambF), (ffis, exs)) -> fpair (asm $ lambF []) \tab mem -> (concatMap ffiDeclare ffis ++) . ("static void foreign(u n) {\n switch(n) {\n" ++) . ffiDefine (length ffis - 1) ffis . ("\n }\n}\n" ++) . ("static const u prog[]={" ++) . foldr (.) id (map (\n -> showInt n . (',':)) $ snd mem []) . ("};\nstatic const u prog_size=sizeof(prog)/sizeof(*prog);\n" ++) . ("static u root[]={" ++) . foldr (\(x, y) f -> maybe undefined showInt (mlookup y tab) . (", " ++) . f) id exs . ("};\n" ++) . ("static const u root_size=" ++) . showInt (length exs) . (";\n" ++) . (foldr (.) id $ zipWith (\p n -> (("EXPORT(f" ++ showInt n ", \"" ++ fst p ++ "\", " ++ showInt n ")\n") ++)) exs (upFrom 0)) $ maybe "" genMain (mlookup "main" tab) }; showTree prec t = case t of { LfVar s@(h:_) -> (if elem h ":!#$%&*+./<=>?@\\^|-~" then par else id) (s++) ; Lf n -> case n of { Basic i -> (i:) ; Const i -> showInt i ; ChrCon c -> ('\'':) . (c:) . ('\'':) ; StrCon s -> ('"':) . (s++) . ('"':) } ; Nd (Lf (Basic 'F')) (Lf (Basic c)) -> ("FFI_"++) . showInt (ord c) ; Nd x y -> (if prec then par else id) (showTree False x . (' ':) . showTree True y) }; disasm (s, t) = (s++) . (" = "++) . showTree False t . (";\n"++); dumpCombs s = case untangle s of { Left err -> err ; Right ((_, lambF), _) -> foldr ($) [] $ map disasm $ nolam $ lambF [] }; showQual (Qual ps t) = foldr (.) id (map showPred ps) . showType t; dumpTypes s = case untangle s of { Left err -> err ; Right ((typed, _), _) -> ($ "") $ foldr (.) id $ map (\(s, q) -> (s++) . (" :: "++) . showQual q . ('\n':)) $ toAscList typed }; getArg' k n = getArgChar n k >>= \c -> if ord c == 0 then pure [] else (c:) <$> getArg' (k + 1) n; getArgs = getArgCount >>= \n -> mapM (getArg' 0) (take (n - 1) $ upFrom 1); interact f = getContents >>= putStr . f; main = getArgs >>= \case { "comb":_ -> interact dumpCombs ; "type":_ -> interact dumpTypes ; _ -> interact compile };
Ben Lynn blynn@cs.stanford.edu 💡