lots of tweaking

Author: cartazio

HLint.hs

@@ -0,0 +1,7 @@
+import "hint" HLint.HLint
+
+ignore "Reduce duplication"
+ignore "Redundant lambda"
+ignore "Use >=>"
+ignore "Use const"
+ignore "Avoid lambda"

hopper.cabal

@@ -56,6 +56,7 @@ library
                     Language.Hopper.Internal.Core.ANF
                     Language.Hopper.Internal.Core.Literal
                     Language.Hopper.Internal.Core.Eval
+                    Language.Hopper.Internal.Core.CPS
   -- Modules included in this library but not exported.
   -- other-modules:
 

src/Language/Hopper/Internal/Core/ANF.hs

@@ -2,10 +2,10 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable,DeriveAnyClass #-}
-{-# LANGUAGE StandaloneDeriving #-}
+-- {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DeriveGeneric #-}
+-- {-# LANGUAGE KindSignatures #-}
+-- {-# LANGUAGE DeriveGeneric #-}
 
 module Language.Hopper.Internal.Core.ANF  where
 
@@ -18,11 +18,13 @@ import  Control.Monad
 import Prelude.Extras
 import Bound
 
-data Atom  ty a = AtomVar !a
+data Atom  ty a =
+    AtomVar !a
     | AtomicLit !Literal
     | AtomLam ![(Text,Type ty,RigModel)] -- do we want to allow arity == 0, or just >= 1?
                 !(Scope Text (ANF ty)  a)
    deriving(Eq,Ord,Functor,Foldable,Traversable,Data,Show,Read)
+
 instance Eq ty => Eq1 (Atom ty)
 instance Show ty => Show1 (Atom ty)
 instance Ord ty => Ord1 (Atom ty)
@@ -33,14 +35,10 @@ instance Show2 Atom
 instance Ord2 Atom
 instance Read2 Atom
 
---instance Applicative (Atom ty) where
---  pure = AtomVar
---  (<*>)= ap
 
---instance Monad (Atom ty) where
---  (AtomVar a) >>= f =  f a
---  (AtomicLit l) >>=  _f =AtomicLit l
---  (AtomLam bs bod) >>= f = AtomLam bs (bod >>>= f)
+--data AnfRHS ty a = PrimApp | FunApp |
+
+data ArgANF ty a = ArgVar a | ArgLit !Literal
 
 data ANF ty a
     = ReturnNF !(Atom ty a)
@@ -50,11 +48,7 @@ data ANF ty a
     | LetApp (Atom ty a) (Atom ty a) (Scope () (ANF ty) a)
 
     -- |
-   deriving (
-    Ord,
-    Functor,
-    Foldable,
-    Traversable,
+   deriving ( Ord, Functor, Foldable, Traversable,
     Data,
     Eq,
     Read,
@@ -76,6 +70,9 @@ instance Applicative (ANF ty) where
 
 instance Monad (ANF ty) where
   (ReturnNF (AtomVar a)) >>=f = f a
+  (ReturnNF (AtomicLit l)) >>= _f = ReturnNF $ AtomicLit l
+  (ReturnNF (AtomLam bs bod)) >>= f = ReturnNF $ AtomLam bs (bod >>>= f)
+  --( ( ) :@@ )
 
   -- return = V
   --V a         >>= f = f a
@@ -85,4 +82,3 @@ instance Monad (ANF ty) where
   --(x :@ y)    >>= f = (x >>= f) :@ (y >>= f)
   --Lam t  e    >>= f = Lam t (e >>>= f)
   --Let t bs  b >>= f = Let t (  bs >>= f)  (b >>>= f)
-

src/Language/Hopper/Internal/Core/CPS.hs

@@ -0,0 +1 @@
+module Language.Hopper.Internal.Core.CPS where

src/Language/Hopper/Internal/Core/Literal.hs

@@ -6,4 +6,6 @@ import Data.Typeable
 import Data.Data
 
 data Literal = LInteger !Integer | LRational !Rational | LNatural !Natural
+
+-- should we add primop namessss?
   deriving(Eq,Ord,Show,Read,Data,Typeable)

src/Language/Hopper/Internal/Core/STLC.hs

@@ -38,7 +38,7 @@ import Control.Lens
 import qualified Control.Monad.Trans.State.Strict as State
 
 import  Control.Monad.Free
-
+import
 -- import Data.Bifunctor
 -- import Data.Bitraversable
 -- import Data.Bifoldable

src/Language/Hopper/Internal/Core/Term.hs

@@ -1 +1,72 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable,DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+
 module Language.Hopper.Internal.Core.Term where
+
+import Language.Hopper.Internal.Core.Literal
+import Language.Hopper.Internal.Core.Type
+import Data.Text (Text)
+import Data.Data
+import Bound
+import Prelude.Extras
+import Control.Monad
+import GHC.Generics (Generic)
+import Data.Traversable (fmapDefault,foldMapDefault)
+
+data Exp ty a
+  = V  a
+  | ELit Literal
+  --  PrimApp a [Atomic a]
+  | Force (Exp ty a)  --- Force is a Noop on evaluate values,
+                      --- otherwise reduces expression to applicable normal form
+                      -- should force be more like seq a b, cause pure
+
+  | Delay (Exp ty a)  --- Delay is a Noop on Thunked values, otherwise creates a thunk
+                      --- note: may need to change their semantics later?!
+  | Exp ty a :@ Exp ty a
+  | Lam [(Text,Type ty,RigModel)] -- do we want to allow arity == 0, or just >= 1?
+        (Scope Text (Exp ty) a)
+  | Let (Text,Type ty,RigModel)  (Exp ty a)  (Scope Text (Exp ty) a) --  [Scope Int Exp a] (Scope Int Exp a)
+  deriving (Typeable,Data,Generic)
+deriving instance (Read a, Read ty) => Read (Exp ty a)
+deriving instance (Read ty) => Read1 (Exp ty)
+deriving instance (Show a, Show ty) => Show (Exp ty a)
+deriving instance (Show ty) => Show1 (Exp ty)
+deriving instance (Ord ty) => Ord1 (Exp ty)
+deriving instance (Ord ty,Ord a) => Ord (Exp ty a)
+deriving instance (Eq ty) => Eq1 (Exp ty)
+deriving instance (Eq a,Eq ty) => Eq (Exp ty a)
+
+instance Functor (Exp ty)  where fmap       = fmapDefault
+
+instance Foldable (Exp ty) where foldMap    = foldMapDefault
+
+instance Applicative (Exp ty) where
+  pure  = V
+  (<*>) = ap
+
+instance Traversable (Exp ty) where
+  traverse f (V a)      = V <$> f a
+  traverse _f (ELit e) = pure $ ELit e
+  traverse f (Force e) = Force <$> traverse f e
+  traverse f (Delay e) = Delay <$> traverse f e
+  traverse f (x :@ y)   = (:@) <$> traverse f x <*> traverse f y
+  traverse f (Lam t e)    = Lam  t <$> traverse f e
+  traverse f (Let t bs b) = Let  t <$>  (traverse f) bs <*> traverse f b
+
+
+instance Monad (Exp ty) where
+  -- return = V
+  V a         >>= f = f a
+  Delay e     >>= f = Delay $ e >>= f
+  Force e     >>= f = Force $ e >>= f
+  ELit e      >>= _f = ELit e -- this could also safely be a coerce?
+  (x :@ y)    >>= f = (x >>= f) :@ (y >>= f)
+  Lam t  e    >>= f = Lam t (e >>>= f)
+  Let t bs  b >>= f = Let t (  bs >>= f)  (b >>>= f)