From: Nathaniel Wesley Filardo Date: Tue, 9 Oct 2012 06:46:30 +0000 (-0400) Subject: Fix cabal build, shuffle backend goo, more tests X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=98bd033c5516a3f75ab6baa3821873ce3b1a4a92;p=dyna2 Fix cabal build, shuffle backend goo, more tests --- diff --git a/README b/README index c0d0c61..fbe3cbd 100644 --- a/README +++ b/README @@ -1,15 +1,19 @@ 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 diff --git a/dyna.cabal b/dyna.cabal index aca5f49..4050792 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -25,7 +25,8 @@ Library ghc-options: -Wall - Exposed-Modules: Dyna.ParserHS.Parser, + Exposed-Modules: Dyna.BackendK3.AST, + Dyna.ParserHS.Parser, Dyna.NormalizeParse, Dyna.XXX.Trifecta @@ -33,10 +34,12 @@ Library 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, @@ -77,11 +80,13 @@ Test-suite dyna-selftests 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, @@ -90,7 +95,7 @@ Test-suite dyna-selftests 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 diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs index 2153bb8..c6a6c00 100644 --- a/src/Dyna/BackendK3/AST.hs +++ b/src/Dyna/BackendK3/AST.hs @@ -85,7 +85,6 @@ class K3Ty (r :: * -> *) where tInt :: r Int tString :: r String tUnit :: r () - tUnk :: r a {- TAddress | TTarget BaseTy -} @@ -95,9 +94,8 @@ class K3Ty (r :: * -> *) where 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) @@ -113,7 +111,6 @@ instance K3Ty UnivTyRepr where 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 @@ -121,6 +118,7 @@ instance K3Ty UnivTyRepr where 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 @@ -137,8 +135,7 @@ instance K3BaseTy () 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 {{{ @@ -154,7 +151,7 @@ data PKind where -- "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. diff --git a/src/Dyna/BackendK3/Automation.hs b/src/Dyna/BackendK3/Automation.hs index 2751c03..df699b6 100644 --- a/src/Dyna/BackendK3/Automation.hs +++ b/src/Dyna/BackendK3/Automation.hs @@ -19,7 +19,13 @@ {-# 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 @@ -63,6 +69,7 @@ instance (K3AutoTy a) => K3AutoTy (Ref a) where autoty = tRef autoty 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) @@ -85,6 +92,36 @@ instance (K3AutoTyTup (wa ': w) (a,b), K3AutoTyTup w b) 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) {{{ diff --git a/src/Dyna/BackendK3/Examples.hs b/src/Dyna/BackendK3/Examples.hs index 0527a8d..0511efd 100644 --- a/src/Dyna/BackendK3/Examples.hs +++ b/src/Dyna/BackendK3/Examples.hs @@ -21,42 +21,26 @@ module Dyna.BackendK3.Examples where 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") @@ -129,12 +113,6 @@ testjoin2 c1 c2 = 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) diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/BackendK3/Render.hs index 6db50bf..043edd0 100644 --- a/src/Dyna/BackendK3/Render.hs +++ b/src/Dyna/BackendK3/Render.hs @@ -43,7 +43,6 @@ instance K3Ty (AsK3Ty e) where tInt = AsK3Ty$ "int" tString = AsK3Ty$ "string" tUnit = AsK3Ty$ "unit" - tUnk = AsK3Ty$ "_" -- tPair (AsK3Ty ta) (AsK3Ty tb) = AsK3Ty$ tupled [ ta, tb ] @@ -166,7 +165,7 @@ instance K3 (AsK3 e) where 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)) @@ -210,7 +209,7 @@ encBag = enclose "{|" "|}" 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 diff --git a/src/Dyna/BackendK3/Selftest.hs b/src/Dyna/BackendK3/Selftest.hs new file mode 100644 index 0000000..b842ba0 --- /dev/null +++ b/src/Dyna/BackendK3/Selftest.hs @@ -0,0 +1,69 @@ +--------------------------------------------------------------------------- +-- 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) + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index e600be1..1b3c476 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -43,11 +43,11 @@ import Dyna.XXX.Trifecta (identNL) ------------------------------------------------------------------------}}} -- 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) @@ -91,7 +91,10 @@ dynaDotOperStyle = IdentifierStyle , 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 @@ -113,16 +116,6 @@ dynaOperStyle = 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" @@ -188,7 +181,7 @@ term = token $ choice [ 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 diff --git a/src/Dyna/ParserHS/ParserSelftest.hs b/src/Dyna/ParserHS/Selftest.hs similarity index 98% rename from src/Dyna/ParserHS/ParserSelftest.hs rename to src/Dyna/ParserHS/Selftest.hs index 33e09fd..ca1d754 100644 --- a/src/Dyna/ParserHS/ParserSelftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -14,7 +14,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} -module Dyna.ParserHS.ParserSelftest where +module Dyna.ParserHS.Selftest where -- import Control.Applicative ((<*)) import Data.ByteString (ByteString) @@ -137,7 +137,8 @@ case_failIncompleteExpr = checkParseFail dterm "foo +" 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 ] diff --git a/src/Dyna/REPL.hs b/src/Dyna/REPL.hs index 5238380..137c6d9 100644 --- a/src/Dyna/REPL.hs +++ b/src/Dyna/REPL.hs @@ -1,16 +1,16 @@ -{-# 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 @@ -25,9 +25,10 @@ main = do 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 diff --git a/src/Dyna/Test/Main.hs b/src/Dyna/Test/Main.hs index b0f2271..bf3df51 100644 --- a/src/Dyna/Test/Main.hs +++ b/src/Dyna/Test/Main.hs @@ -3,11 +3,13 @@ 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 ] diff --git a/src/Dyna/XXX/THTuple.hs b/src/Dyna/XXX/THTuple.hs index ec6203a..ec7f4cc 100644 --- a/src/Dyna/XXX/THTuple.hs +++ b/src/Dyna/XXX/THTuple.hs @@ -25,8 +25,15 @@ module Dyna.XXX.THTuple( -- * 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 @@ -58,8 +65,8 @@ class (MKLT (TOL base) ~ base) => Tupled base where -- | 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 @@ -79,7 +86,7 @@ class (MKLT (TOL base) ~ base) => Tupled base where -- 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 :: (* -> *) diff --git a/src/Dyna/XXX/THTupleInternals.hs b/src/Dyna/XXX/THTupleInternals.hs index cd9fdc1..3bbb9fd 100644 --- a/src/Dyna/XXX/THTupleInternals.hs +++ b/src/Dyna/XXX/THTupleInternals.hs @@ -161,11 +161,24 @@ mkRTupleInstance _tc _rte _rtr _opel n | n > 1 = do 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 @@ -204,6 +217,7 @@ mkRecInstance (_cname,_cargs) _ntyf _dnames _tnames _trnames n = do $ 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