An overview of the source tree
------------------------------
-src/Dyna/ParserHS -- the Haskell front-end parser and selftests
+src/Dyna/BackendK3 -- An AST and printer for K3,
+ -- done in finally-tagless style.
+ -- Includes some "Examples", even if not self-tests.
-src/Dyna/Term -- Different representations of terms and
- utilities
+src/Dyna/ParserHS -- the Haskell front-end parser and selftests
-src/Dyna/Test -- code used by self-tests throughout the codebase
+src/Dyna/Term -- Different representations of terms and
+ utilities
-src/Dyna/XXX -- code that should probably go upstream;
- modules here are named by the upstream package.
+src/Dyna/Test -- code used by self-tests throughout the codebase
+
+src/Dyna/XXX -- code that should probably go upstream;
+ modules here are named by the upstream package.
For those not familar with cabal
ghc-options: -Wall
- Exposed-Modules: Dyna.ParserHS.Parser,
+ Exposed-Modules: Dyna.BackendK3.AST,
+ Dyna.ParserHS.Parser,
Dyna.NormalizeParse,
Dyna.XXX.Trifecta
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
+ ghc-prim,
mtl >=2.1,
parsers >=0.3,
reducers >=3.0,
semigroups >=0.8,
+ template-haskell,
trifecta >=0.90,
unification-fd,
unordered-containers>=0.2,
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
+ ghc-prim,
HUnit >=1.2,
mtl >=2.1,
parsers >=0.3,
reducers >=3.0,
semigroups >=0.8,
+ template-haskell,
test-framework >=0.6,
test-framework-hunit >=0.2,
test-framework-th >=0.2,
utf8-string >=0.3,
wl-pprint-extras >=3.0
- Other-Modules: Dyna.ParserHS.ParserSelftest
+ Other-Modules: Dyna.BackendK3.Examples
Main-Is: Dyna/Test/Main.hs
tInt :: r Int
tString :: r String
tUnit :: r ()
- tUnk :: r a
{- TAddress | TTarget BaseTy -}
tColl :: CollTy c -> r a -> r (CTE c a)
tFun :: r a -> r b -> r (a -> b)
-
- -- XXX TUPLES
- -- tTuple :: (RTupled rt, RTR rt ~ r) => rt -> r (RTE rt)
+ -- XXX TUPLES
+ -- tTuple :: (RTupled rt, RTR rt ~ r, RTE rt ~ t) => rt -> r t
tTuple2 :: (r a, r b) -> r (a,b)
tTuple3 :: (r a, r b, r c) -> r (a,b,c)
tTuple4 :: (r a, r b, r c, r d) -> r (a,b,c,d)
tInt = UTR tInt
tString = UTR tString
tUnit = UTR tUnit
- tUnk = UTR tUnk
tColl c (UTR a) = UTR $ tColl c a
tFun (UTR a) (UTR b) = UTR $ tFun a b
tRef (UTR a) = UTR $ tRef a
-- XXX TUPLES
+ -- tTuple us = UTR $ tTuple $ tupleopRS unUTR us
tTuple2 us = UTR $ tTuple2 $ tupleopRS unUTR us
tTuple3 us = UTR $ tTuple3 $ tupleopRS unUTR us
tTuple4 us = UTR $ tTuple4 $ tupleopRS unUTR us
instance (K3BaseTy a) => K3BaseTy (CTE c a)
instance (K3BaseTy a) => K3BaseTy (Maybe a)
instance (K3BaseTy a) => K3BaseTy (Ref a)
-instance (K3BaseTy a, K3BaseTy b) => K3BaseTy (a,b)
-instance (K3BaseTy a, K3BaseTy b, K3BaseTy c) => K3BaseTy (a,b,c)
+$(mkTupleRecInstances ''K3BaseTy [])
------------------------------------------------------------------------}}}
-- Pattern System {{{
-- "a". This will in general be true of any variant (i.e. sum) pattern.
PKJust :: PKind -> PKind
- -- | Pair patterns
+ -- | Product ("tuple") patterns
--
-- Product patterns, on the other hand, have PatTy and PatReprFn both
-- producing tuples.
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-module Dyna.BackendK3.Automation where
+module Dyna.BackendK3.Automation (
+ -- * Automated derivation of data from types, where possible
+ K3AutoColl, autocoll, K3AutoTy, autoty,
+
+ -- * K3 macro library
+ macro_localVar, macro_caseMaybe, macro_emptyPeek
+) where
import Data.Word
import Text.PrettyPrint.Free
instance (K3AutoTy a, K3AutoTy b) => K3AutoTy (a -> b) where
autoty = tFun autoty autoty
+ -- XXX TUPLES
instance (K3AutoTy a, K3AutoTy b) => K3AutoTy (a,b)
where autoty = tTuple2 (autoty, autoty)
where autoty = tTuple autotytup
-}
+------------------------------------------------------------------------}}}
+-- K3 Macro Library (XXX WIP) {{{
+
+ -- | Let as lambda
+macro_localVar :: (K3 r, K3BaseTy a, K3AST_Pat_C r (PKVar a))
+ => UnivTyRepr a
+ -> (r a)
+ -> (r a -> r b)
+ -> r b
+macro_localVar w a b = eApp (eLam (PVar w) b) a
+
+ -- | Case analyze a Maybe
+macro_caseMaybe :: (K3 r, K3BaseTy a, K3AST_Pat_C r (PKJust (PKVar a)))
+ => UnivTyRepr a
+ -> r (Maybe a)
+ -> r b
+ -> (r a -> r b)
+ -> r b
+macro_caseMaybe w m n b = eITE (eEq m cNothing)
+ n
+ (eApp (eLam (PJust (PVar w)) b) m)
+
+ -- | Case analyze a collection as either empty or a peeked element
+macro_emptyPeek :: (K3AST_Coll_C r c, K3AST_Pat_C r (PKVar a),
+ K3 r, K3BaseTy a, K3AutoTy a)
+ => r (CTE c a) -> r b -> (r a -> r b) -> r b
+macro_emptyPeek c e l = eITE (eEq c eEmpty)
+ e
+ (eApp (eLam (PVar autoty) l) $ ePeek c)
+
------------------------------------------------------------------------}}}
-- Collect variables in a term (XXX TODO) {{{
import Dyna.BackendK3.AST
import Dyna.BackendK3.Automation
import Dyna.BackendK3.Render
+import Text.PrettyPrint.Free
------------------------------------------------------------------------}}}
--- Example cases: macros
+-- Example cases: misc
------------------------------------------------------------------------{{{
-macro_caseMaybe :: (K3 r, K3BaseTy a, K3AST_Pat_C r (PKJust (PKVar a)))
- => UnivTyRepr a
- -> r (Maybe a)
- -> r b
- -> (r a -> r b)
- -> r b
-macro_caseMaybe w m n b = eITE (eEq m cNothing)
- n
- (eApp (eLam (PJust (PVar w)) b) m)
-
-test_macroCM = Decl (Var "nocase")
- (tInt)
- $Just $ macro_caseMaybe tInt (eVar (Var "test") autoty) (cInt 0) (id)
+ -- | Perform a simple join of two collections using a predicate and apply
+ -- some function to rows that match.
+ --
+ -- This is intended to be sufficiently simple for K3 to chew on and
+ -- do something useful with in its optimizer backend.
macro_simple_join2 :: (K3 r, K3AutoTy a, K3BaseTy a, K3AST_Pat_C r (PKVar a),
K3AutoTy b, K3BaseTy b, K3AST_Pat_C r (PKVar b))
- => r (a -> b -> Bool) -> r (CTE c1 a) -> r (CTE c2 b) -> r ()
-macro_simple_join2 p c1 c2 =
- flip eIter c1 $ eLam (PVar autoty) $ \a -> flip eIter c2
- $ eLam (PVar autoty) $ \b -> eITE (eApp (eApp p a) b) (cUnit) (cUnit)
-
-macro_emptyPeek :: (K3AST_Coll_C r c, K3AST_Pat_C r (PKVar a),
- K3 r, K3BaseTy a, K3AutoTy a)
- => r (CTE c a) -> r b -> (r a -> r b) -> r b
-macro_emptyPeek c e l = eITE (eEq c eEmpty)
- e
- (eApp (eLam (PVar autoty) l) $ ePeek c)
-
-------------------------------------------------------------------------}}}
--- Example cases: misc
-------------------------------------------------------------------------{{{
+ => r (a -> b -> Bool) -> r (a -> b -> ())
+ -> r (CTE c1 a) -> r (CTE c2 b) -> r ()
+macro_simple_join2 p f c1 c2 =
+ flip eIter c1 $ eLam (PVar autoty) $ \a ->
+ flip eIter c2 $ eLam (PVar autoty) $ \b ->
+ eITE (eApp (eApp p a) b) (eApp (eApp f a) b) (cUnit)
testdecf = Decl (Var "f")
eLam p (\(k1b,k2b,_) ->
(eEq k1a k1b) `eAdd` (eEq k2a k2b))))
-macro_localVar :: (K3 r, K3BaseTy a, K3AST_Pat_C r (PKVar a))
- => UnivTyRepr a
- -> (r a)
- -> (r a -> r b)
- -> r b
-macro_localVar w a b = eApp (eLam (PVar w) b) a
testlocal = macro_localVar autoty
(eEmpty `asColl` CTBag)
tInt = AsK3Ty$ "int"
tString = AsK3Ty$ "string"
tUnit = AsK3Ty$ "unit"
- tUnk = AsK3Ty$ "_"
-- tPair (AsK3Ty ta) (AsK3Ty tb) = AsK3Ty$ tupled [ ta, tb ]
eNeq = binop "!="
eLam w f = AsK3$ \n -> let ((pat, arg),n') = runState (k3pfn w) n
- in align ("\\" <> pat <+> "->" `above` unAsK3 (f arg) n')
+ in "\\" <> pat <+> "->" <+> align (unAsK3 (f arg) n')
eApp (AsK3 f) (AsK3 x) = AsK3$ \n ->
parens (parens (f n) `aboveBreak` parens (x n))
binop :: Doc e -> AsK3 e a -> AsK3 e b -> AsK3 e c
binop o (AsK3 a) (AsK3 b) = AsK3$ \n -> parens (align $ a n)
</> o
- </> parens (align $ b n)
+ <+> parens (align $ b n)
-- Overly polymorphic; use only when correct!
builtin :: Doc e -> [ Int -> Doc e ] -> AsK3 e b
--- /dev/null
+---------------------------------------------------------------------------
+-- Header material
+------------------------------------------------------------------------{{{
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Dyna.BackendK3.Selftest where
+
+import Dyna.BackendK3.AST
+import Dyna.BackendK3.Automation
+import Dyna.BackendK3.Render
+import qualified Test.Framework as TF
+import Test.Framework.Providers.HUnit
+import Test.Framework.TH
+import Test.HUnit
+import Text.PrettyPrint.Free
+
+------------------------------------------------------------------------}}}
+-- Match some K3 to strings {{{
+
+ -- | Produce a version of the Doc with minimal formatting
+displaySimple :: SimpleDoc e -> ShowS
+displaySimple (SEmpty ) = id
+displaySimple (SChar c d) = showChar c . displaySimple d
+displaySimple (SText _ s d) = showString s . displaySimple d
+displaySimple (SLine _ d) = showChar ' ' . displaySimple d
+displaySimple (SEffect _ d) = displaySimple d
+
+render :: AsK3 e a -> String
+render = flip displaySimple [] . renderCompact . sh
+
+------------------------------------------------------------------------}}}
+-- Basic handling {{{
+
+case_mfn :: Assertion
+case_mfn = e @=? render k3
+ where
+ e = "\\x0:int -> -((x0) + (1))"
+ -- Note that we cannot automate the tInt here, since K3's math
+ -- operators are overloaded, so there's no way to conclude
+ -- the type of a from the occurrance of "a + Int".
+ k3 = eLam (PVar tInt) (\a -> eNeg $ eAdd a $ cInt 1)
+
+case_pairfn :: Assertion
+case_pairfn = e @=? render k3
+ where
+ e = "\\(x0:int ,x1:bool) -> x0"
+ k3 = eLam (PTup (PVar tInt, PVar tBool)) (\(a,_) -> a)
+
+------------------------------------------------------------------------}}}
+-- Macro expansion test cases {{{
+
+case_mcm :: Assertion
+case_mcm = e @=? render k3
+ where
+ e = "if ((test) == (nothing)) then (0) "
+ <> "else (((\\just (x0:int) -> x0) (test)))"
+ k3 = macro_caseMaybe tInt (eVar (Var "test") autoty) (cInt 0) (id)
+
+------------------------------------------------------------------------}}}
+-- Harness toplevel {{{
+
+selftest :: TF.Test
+selftest = $(testGroupGenerator)
+
+main :: IO ()
+main = $(defaultMainGenerator)
+
+------------------------------------------------------------------------}}}
------------------------------------------------------------------------}}}
-- Parsed output definition {{{
-data Annotation = AnnType !B.ByteString
+data Annotation = AnnType (Spanned Term)
deriving (Eq,Ord,Show)
data Term = TFunctor {-# UNPACK #-} !B.ByteString ![Spanned Term]
- | TAnnot {-# UNPACK #-} !Annotation !(Spanned Term)
+ | TAnnot Annotation !(Spanned Term)
| TVar {-# UNPACK #-} !B.ByteString
-- | TDBLit XXX
deriving (Eq,Ord,Show)
, styleReservedHighlight = ReservedOperator
}
- -- | Colon is not a permitted beginning to a prefix
+ -- Dot is handled specially elsewhere due to its
+ -- dual purpose as an operator and rule separator.
+ --
+ -- Colon is not a permitted beginning to a prefix
-- operator, as it is a sigil for type annotations.
dynaPfxOperStyle :: TokenParsing m => IdentifierStyle m
dynaPfxOperStyle = IdentifierStyle
, styleReservedHighlight = ReservedOperator
}
-dynaTypeStyle :: TokenParsing m => IdentifierStyle m
-dynaTypeStyle = IdentifierStyle
- { styleName = "Type Annotation"
- , styleStart = char ':'
- , styleLetter = (alphaNum <|> oneOf "_'")
- , styleReserved = mempty
- , styleHighlight = Operator
- , styleReservedHighlight = ReservedOperator
-}
-
dynaAtomStyle :: TokenParsing m => IdentifierStyle m
dynaAtomStyle = IdentifierStyle
{ styleName = "Atom"
[ parens texpr
, spanned $ TVar <$> (bsf $ ident dynaVarStyle)
, try $ spanned $ flip TFunctor [] <$> atom <* (notFollowedBy $ char '(')
- , try $ spanned $ mkta <$> (bsf $ ident dynaTypeStyle) <* spaces <*> term
+ , try $ spanned $ mkta <$> (colon *> term) <* spaces <*> term
, spanned $ parenfunc
]
where
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
-module Dyna.ParserHS.ParserSelftest where
+module Dyna.ParserHS.Selftest where
-- import Control.Applicative ((<*))
import Data.ByteString (ByteString)
case_tyAnnot :: Assertion
case_tyAnnot = e @=? (term fintx)
where
- e = TFunctor "f" [TAnnot (AnnType ":int")
+ e = TFunctor "f" [TAnnot (AnnType $ TFunctor "int" []
+ :~ Span (Columns 3 3) (Columns 7 7) fintx)
(TVar "X" :~ Span (Columns 7 7) (Columns 8 8) fintx)
:~ Span (Columns 2 2) (Columns 8 8) fintx
]
-{-# LANGUAGE Rank2Types #-}
+
module Dyna.REPL where
import Control.Applicative ((<*))
import Control.Monad.Trans (liftIO)
import System.Console.Haskeline
+import Text.PrettyPrint.Free
import Text.Trifecta
import qualified Dyna.ParserHS.Parser as DP
-- import qualified Dyna.NormalizeParse as DNP
import Dyna.XXX.Trifecta
-
main :: IO ()
main = do
runInputT defaultSettings loop
failure
l
- -- Interaction interprets a ^D in nested context
- -- as an excuse to print out parsing errors
- -- (i.e. it why it rejected the line
+ -- Interaction interprets a ^D in nested context
+ -- as an excuse to print out parsing errors
+ -- (i.e. it why it rejected the line thus far);
+ -- TODO is that what we want?
promptCont = getInputLine " "
success a = do
module Dyna.Test.Main where
import Test.Framework
-import qualified Dyna.ParserHS.ParserSelftest as DPHS
-import qualified Dyna.XXX.TrifectaTests as DXT
+import qualified Dyna.BackendK3.Selftest as DK3S
+import qualified Dyna.ParserHS.Selftest as DPHS
+import qualified Dyna.XXX.TrifectaTests as DXT
main :: IO ()
main = defaultMain
[DPHS.selftest
+ ,DK3S.selftest
, DXT.selftest
]
-- * Classes on tuples and rtuples
Tupled(..),RTupled(..),
- -- * Template Haskell utility functions for type-level
- mkRecInstances, mkTyMap, mkTyMapFlat, mkTyUnMap,
+ -- * Template Haskell utility for recursive instances
+ mkTupleRecInstances,
+
+ -- * Template Haskell utility functions for type-level shifting
+ mkTyMap, mkTyMapFlat, mkTyUnMap,
+
+ {-
+ mkRecInstances,
+ -}
-- * Template Haskell utility functions for data-level
mkLRecInstances
-- | Apply r to each element of the tuple
type RTER base (r :: * -> *) :: *
- -- | Go from the tuple representation to a promoted list;
- -- the inverse of MKLT (as asserted by class constraints).
+ -- | Go from the tuple representation to a promoted list;
+ -- the inverse of MKLT (as asserted by class constraints).
type TOL base :: [*]
-- | Shed a type constructor
-- on RTER and MKRLT.
class (Tupled (RTE arred),
RTER (RTE arred) (RTR arred) ~ arred,
- MKRLT (RTR arred) (TOL (RTE arred)) ~ arred
+ MKRLT (RTR arred) (TOL (RTE arred)) ~ arred
)
=> RTupled arred where
type RTR arred :: (* -> *)
mkRTupleInstances a b c d = foreachTupleSize (mkRTupleInstance a b c d)
------------------------------------------------------------------------}}}
--- Make recursive type-math classes which walk tuple types {{{
+-- Make recursive type-math classes which walk tuple types (XXX) {{{
- -- XXX TUPLES Can't yet generate the closed lifted-ADTs we use
- -- for class heads.
+mkTupleRecInstance :: Name -- ^ Class name
+ -> [TypeQ] -- ^ Threaded arguments
+ -> Int -- ^ Tuple size
+ -> Q Dec
+mkTupleRecInstance _cname _cargs n = do
+ names <- mkNames n
+ let context = cxt $ map (\na -> classP _cname $ _cargs ++ [varT na]) names
+
+ instanceD context
+ (genMap appT (conT _cname) (id) $ _cargs ++ [mkTy n names])
+ []
+mkTupleRecInstances a b = foreachTupleSize (mkTupleRecInstance a b)
+
+
+{-
mkRecInstance :: (Name, [TypeQ]) -- ^ Class name and threaded arguments
-> (Int -> Name) -- ^ Instance argument maker
-> [(Name,Int -> Name)] -- ^ Datas and constructor-maker
$ concat [datas,types,rtypes]
mkRecInstances a b c d e = foreachTupleSize (mkRecInstance a b c d e)
+-}
mkLRecInstance :: (Name, [TypeQ]) -- ^ Class name and args
-> Name
projects / dyna2 / commitdiff