instr i = tell i >> pure undefined
freshLabel :: Compiler Int
-freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs)
+freshLabel = gets fresh >>= \(f:fs)->modify (\s->s { fresh=fs }) >> pure f
binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b
binop i l r = l >> r >> instr [i]
unop i l = l >> instr [i]
instance Expression Compiler where
- lit v = instr $ map Push $ serialise v []
+ lit v = instr [Push $ serialise v]
(+.) = binop Add
(-.) = binop Sub
(/.) = binop Div
int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
int program memory registers = do
instruction <- readArray program $ pc registers
--- stack <- getElems memory
let reg = registers { pc = pc registers + 1 }
--- case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of
case instruction of
Str r -> do
(reg', v) <- pop memory reg
int program memory $ reg' { gp = DM.insert r v (gp reg')}
Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
--- Roll 0 _ -> int program memory reg
--- Roll 1 _ -> int program memory reg
--- Roll _ 0 -> int program memory reg
--- Roll depth num -> do
--- (reg', vs) <- popn memory depth reg
--- foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory
--- where
--- roll 0 acc vs = vs ++ reverse acc
--- roll n acc [] = roll n [] $ reverse acc
--- roll n acc (v:vs) = roll (n-1) (v:acc) vs
Pop n -> popn memory n reg >>= int program memory . fst
Push v -> push memory v reg >>= int program memory
--- Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory
Add -> bop (+) memory reg >>= int program memory
Sub -> bop (-) memory reg >>= int program memory
Mul -> bop (*) memory reg >>= int program memory
-> case dec of
DataD _ _ tyvars _ constructors _
-> sequence
- [ mkDerivation tyvars
- , mkConstructorClasses tyvars constructors
+ [ {-mkDerivation tyvars
+ ,-}mkConstructorClasses tyvars constructors
, mkPrinterInstances constructors
, mkCompilerInstances constructors
]
_
-> fail "mkConsClass only supports types"
where
- mkDerivation :: [TyVarBndr] -> DecQ
- mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
- InstanceD Nothing
- [ConT (mkName "Serialise") `AppT` t | t <- names]
- (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
- []
+-- mkDerivation :: [TyVarBndr] -> DecQ
+-- mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
+-- InstanceD Nothing
+-- [ConT (mkName "Serialise") `AppT` t | t <- names]
+-- (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
+-- []
mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ
mkConstructorClasses tyvars constructors = do
mkSelectorClassMember (NormalC consName fs)
= mapM (uncurry mkSelectorClassMemberForField)
$ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..]
- mkSelectorClassMember (RecC _ fs)
- = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
+ mkSelectorClassMember (RecC consName fs)
+ = (++) <$> mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
+ <*> mapM (uncurry mkSelectorClassMemberForField)
+ (zipWith (\(_, _, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..])
+
mkSelectorClassMember t
= fail $ "mkConsClass not supported for types such as: " ++ show t
])
<*> mapM mkPrinterSelector
(zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
- mkPrinterInstance (RecC name fs)
+ mkPrinterInstance (RecC consName fs)
= let args = map mkName $ numberedArgs fs
- in (:) <$> pure (FunD (constructorName name)
+ in (:) <$> pure (FunD (constructorName consName)
[Clause
(map VarP args)
(NormalB $
)
[]
])
- <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
+ <*> ((++)
+ <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
+ <*> mapM mkPrinterSelector
+ (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
+ )
mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
mkPrinterSelector :: String -> Q Dec
<*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
mkCompilerInstance (RecC consName fs) consnum = (:)
<$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs]
- <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
+ <*> ((++)
+ <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
+ <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
+ )
mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
import Data.Char
import Data.List
+import Data.Maybe
import Debug.Trace
import Control.Applicative
pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
+pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
+pCBrack p = pSat (COpen==) *> p <* pSat (CClose==)
+
pCase :: (MonadFail m, Alternative m) => RParser m Token Exp
pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
where
mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
where
mkCaseMatch :: Pat -> Exp -> Exp -> Exp
- mkCaseMatch (VarP v) e _ = LetE [FunD v [Clause [] (NormalB name) []]] e
- mkCaseMatch WildP e _ = e
- mkCaseMatch (ConP consName fields) e rest
- = VarE (mkName "if'")
- `AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate
- `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0 :: Int ..]] e
- `AppE` rest
- where
- mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []]
--- mkFieldMatch idx p@(ConP consName fields) = FunD (mkName "f0") [Clause [] (NormalB $ mkCaseMatch p e (LitE (StringL "Exhausted case"))) []]
- mkFieldMatch _ p = error $ "Unsupported subpat: " ++ show p
-
- mkCaseMatch p _ _ = error $ "Unsupported pat: " ++ show p
+ mkCaseMatch a e rest = case mkCasePred name a of
+ Nothing -> LetE (mkCaseBinding name a []) e
+ Just p -> VarE (mkName "if'") `AppE` p `AppE` LetE (mkCaseBinding name a []) e `AppE` rest
+
+ mkCasePred :: Exp -> Pat -> Maybe Exp
+ mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
+ (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
+ $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
+ mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.")
+ (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
+ $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields]
+ mkCasePred _ (VarP _) = Nothing
+ mkCasePred _ WildP = Nothing
+ mkCasePred objName (ParensP p) = mkCasePred objName p
+ mkCasePred objName (AsP _ p) = mkCasePred objName p
+ mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName)
+ mkCasePred _ p = error $ "Unsupported pat: " ++ show p
+
+ mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec]
+ mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $
+ [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
+ mkCaseBinding objName (RecP consName fields) ds = foldr ($) ds $
+ [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields]
+ mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds
+ mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds
+ mkCaseBinding _ (LitP _) ds = ds
+ mkCaseBinding _ WildP ds = ds
+ mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds
+ mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
-pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp
+pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp <* optional (pSat (==SColon))
pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
pExp
pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
pPat
- = ConP <$> pCon <*> many pPat
+ = RecP <$> pCon <*> pCBrack pFieldPat
+ <|> ConP <$> pCon <*> many pPat
+ <|> AsP <$> pVar <* pSat (At==) <*> pPat
<|> VarP <$> pVar
<|> WildP <$ pSat (Underscore==)
+ <|> LitP <$> pLit
<|> pBrack pPat
+ where
+ pFieldPat = pSepBy (pSat (==Comma)) $
+ (,) <$> pVar <* pSat (==Equal) <*> pPat
parseCP :: MonadFail m => [Char] -> m Exp
-parseCP s = case runParser pCase (lexer s) of
- Nothing -> fail "Parsing failed"
- Just (_, _:_) -> fail "Non-exhaustive parse found"
- Just (e, []) -> pure e
-
-data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String} | Case | Of | Op String | BOpen | BClose | Underscore | Unknown Char
+--parseCP s = case runParser pCase (lexer s) of
+parseCP s = case runParser pCase (lexer (trace (show s) s)) of
+-- Nothing -> fail $ "Parsing failed for: " ++ show (lexer s)
+ [] -> fail $ "Parsing failed for: " ++ show (lexer s)
+-- Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t
+ (e, []):_ -> pure e
+-- x -> fail $ "Multiple parses: " ++ show x
+-- Just (e, []) -> pure e
+
+data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String}
+ | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma
+ | Unknown Char
deriving (Eq, Show)
lexer :: [Char] -> [Token]
lexer ('(':rest) = BOpen:lexer rest
lexer (')':rest) = BClose:lexer rest
lexer ('_':rest) = Underscore:lexer rest
+lexer (';':rest) = SColon:lexer rest
+lexer ('@':rest) = At:lexer rest
+lexer ('{':rest) = COpen:lexer rest
+lexer ('}':rest) = CClose:lexer rest
+lexer ('=':rest) = Equal:lexer rest
+lexer (',':rest) = Comma:lexer rest
lexer ('\'':'\\':x:'\'':rest) = case x of
'\'' -> Lit (CharL '\''):lexer rest
'\\' -> Lit (CharL '\\'):lexer rest
| isAlpha d && isLower d = case span isAlpha rest of
(s, rest') -> Var (d:s):lexer rest'
| isDigit d || d == '-' || d == '+' = case span isDigit rest of
- (s, rest') -> Lit (IntegerL $ read (d:s)):lexer rest'
+ (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
| isSpace d = lexer rest
| otherwise = Unknown d:lexer rest
lexer [] = []
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveGeneric #-}
module Main where
import Language
f5
= fun ( \sumf->(\l->[cp|case l of
Cons e rest -> e +. sumf rest
- _ -> 0
--- Cons e (Cons f rest) -> e +. f +. sum rest
-{-blup-}
+ Nil -> 0
|])
+-- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
:- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
)
+
+f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int)
+f6
+ = fun ( \firstfun->(\l->[cp|case l of
+ TupleR{first=f} -> f
+ |])
+-- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
+ :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')}
+ )
import GHC.Generics
class Serialise a where
- serialise :: a -> [Int] -> [Int]
- default serialise :: (Generic a, GSerialise (Rep a)) => a -> [Int] -> [Int]
- serialise = gserialise . from
+ serialise :: a -> Int
-class GSerialise f where
- gserialise :: f a -> [Int] -> [Int]
-
---Void
-instance GSerialise V1 where
- gserialise _ = id
---Unit
-instance GSerialise U1 where
- gserialise _ = id
---Pair
-instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where
- gserialise (l :*: r) = gserialise l . gserialise r
---Constants, additional parameters and recursion of kind *
-instance Serialise a => GSerialise (K1 i a) where
- gserialise (K1 a) = serialise a
---Either not supported because we don't support sumtypes in our stack machine
-instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where
- gserialise (L1 l) = (0:) . gserialise l
- gserialise (R1 r) = (1:) . gserialise r
---Datatype, Constructor or Selector
-instance (GSerialise a) => GSerialise (M1 i c a) where
- gserialise (M1 l) = gserialise l
+--class serialise a where
+-- serialise :: a -> int -> [int] -> [int]
+-- default serialise :: (generic a, gserialise (rep a)) => a -> int -> [int] -> [int]
+-- serialise = gserialise . from
+--
+--class GSerialise f where
+-- gserialise :: f a -> Int -> [Int] -> [Int]
+--
+----Void
+--instance GSerialise V1 where
+-- gserialise _ _ = id
+----Unit
+--instance GSerialise U1 where
+-- gserialise _ _ = id
+----Pair
+--instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where
+-- gserialise (l :*: r) _ = gserialise l 0 . gserialise r 0
+----Constants, additional parameters and recursion of kind *
+--instance Serialise a => GSerialise (K1 i a) where
+-- gserialise (K1 a) i = serialise a i
+----Either not supported because we don't support sumtypes in our stack machine
+--instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where
+-- gserialise (L1 l) c = gserialise l (c * 2)
+-- gserialise (R1 r) c = gserialise r (c + 1)
+----Datatype, Constructor or Selector
+--instance (GSerialise a) => GSerialise (M1 i c a) where
+-- gserialise (M1 l) c = (c:) . gserialise l 0
instance Serialise Int where
- serialise i = (i:)
+ serialise i = i
instance Serialise Bool where
- serialise b = ((if b then 1 else 0):)
+ serialise b = if b then 1 else 0
instance Serialise Char where
- serialise c = (ord c:)
+ serialise c = ord c
$(mkConsClass ''TupleR)
data List a = Nil | Cons a (List a)
- deriving Generic
+ deriving (Generic, Show)
$(mkConsClass ''List)
repositories / clean-tests.git / commitdiff