Big cleanup of Main.hs

app/Main.hs

@@ -8,14 +8,12 @@
 
 module Main where
 
-import           Control.Arrow
 import           Control.Monad
 import           Control.Monad.Catch
 import           Control.Monad.Fix
 import           Control.Monad.Supply
 import           Control.Monad.Trans
 import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
 import           Data.Maybe
 import           Data.Monoid
 import           Data.Text (Text)
@@ -31,87 +29,93 @@ import           Duet.Supply
 import           Duet.Types
 import           System.Environment
 
+-- | Main entry point.
 main :: IO ()
 main = do
   args <- getArgs
   case args of
     (file:is) -> do
       text <- T.readFile file
-      compileStepText "<interactive>" (listToMaybe is) text
+      evalSupplyT
+        (do (binds, context) <- createContext "<interactive>" text
+            maybe (return ()) (runStepper context binds) (listToMaybe is))
+        [1 ..]
     _ -> error "usage: duet <file>"
 
-compileStepText :: String -> Maybe String -> Text -> IO ()
-compileStepText file i text =
-  case parseText file text of
-    Left e -> error (show e)
-    Right decls -> do
-      evalSupplyT
-        (do (bindGroups, context) <- runTypeChecker decls
-            let specials = contextSpecials context
-            typeClassEnv' <-
-              fmap
-                M.fromList
-                (mapM
-                   (\(name, cls) -> do
-                      is <-
-                        mapM
-                          (\inst -> do
-                             ms <-
-                               mapM
-                                 (\(nam, alt) ->
-                                    fmap
-                                      (nam, )
-                                      (resolveAlt
-                                         (contextTypeClasses context)
-                                         (contextSpecialTypes context)
-                                         alt))
-                                 (M.toList
-                                    (dictionaryMethods (instanceDictionary inst)))
-                             pure
-                               inst
-                               { instanceDictionary =
-                                   (instanceDictionary inst)
-                                   {dictionaryMethods = M.fromList ms}
-                               })
-                          (classInstances cls)
-                      pure (name, cls {classInstances = is}))
-                   (M.toList (contextTypeClasses context)))
-            bindGroups' <-
-              (mapM
-                 (resolveBindGroup typeClassEnv' (contextSpecialTypes context))
-                 bindGroups)
-            case i of
-              Nothing -> return ()
-              Just i' -> do
-                e0 <- lookupNameByString i' bindGroups'
-                fix
-                  (\loopy lastString e -> do
-                     e' <-
-                       expandSeq1
-                         typeClassEnv'
-                         (contextSpecialSigs context)
-                         (contextSignatures context)
-                         e
-                         bindGroups'
-                     let string = printExpression (defaultPrint) e
-                     when
-                       (string /= lastString && (True || cleanExpression e))
-                       (liftIO (putStrLn string))
-                     if fmap (const ()) e' /= fmap (const ()) e
-                       then do
-                         renameExpression
-                           specials
-                           (contextScope context)
-                           (contextDataTypes context)
-                           e' >>=
-                           loopy string
-                       else pure ())
-                  ""
-                  e0)
-        [0 ..]
+--------------------------------------------------------------------------------
+-- Context setup
+
+-- | Create a context of all renamed, checked and resolved code.
+createContext
+  :: (MonadSupply Int m, MonadThrow m)
+  => String
+  -> Text
+  -> m ([BindGroup Type Name (TypeSignature Type Name Location)], Context Type Name Location)
+createContext file text = do
+  do decls <- parseText file text
+     builtins <- setupEnv mempty
+     let specials = builtinsSpecials builtins
+     -- Renaming
+     (typeClasses, signatures, renamedBindings, scope, dataTypes) <-
+       renameEverything decls specials builtins
+     -- Type class definition
+     addedTypeClasses <- addClasses builtins typeClasses
+     -- Type checking
+     (bindGroups, typeCheckedClasses) <-
+       typeCheckModule
+         addedTypeClasses
+         signatures
+         (builtinsSpecialTypes builtins)
+         renamedBindings
+     -- Type class resolution
+     resolvedTypeClasses <-
+       resolveTypeClasses typeCheckedClasses (builtinsSpecialTypes builtins)
+     resolvedBindGroups <-
+       mapM
+         (resolveBindGroup resolvedTypeClasses (builtinsSpecialTypes builtins))
+         bindGroups
+     -- Create a context of everything
+     let context =
+           Context
+           { contextSpecialSigs = builtinsSpecialSigs builtins
+           , contextSpecialTypes = builtinsSpecialTypes builtins
+           , contextSignatures = signatures
+           , contextScope = scope
+           , contextTypeClasses = resolvedTypeClasses
+           , contextDataTypes = dataTypes
+           }
+     pure (resolvedBindGroups, context)
 
 --------------------------------------------------------------------------------
--- Clean expressions
+-- Stepper
+
+-- | Run the substitution model on the code.
+runStepper
+  :: (MonadIO m, MonadSupply Int m, MonadThrow m)
+  => Context Type Name Location
+  -> [BindGroup Type Name (TypeSignature Type Name Location)]
+  -> String
+  -> m ()
+runStepper context bindGroups' i = do
+  e0 <- lookupNameByString i bindGroups'
+  fix
+    (\loopy lastString e -> do
+       e' <- expandSeq1 context bindGroups' e
+       let string = printExpression (defaultPrint) e
+       when
+         (string /= lastString && (True || cleanExpression e))
+         (liftIO (putStrLn string))
+       if fmap (const ()) e' /= fmap (const ()) e
+         then do
+           renameExpression
+             (contextSpecials context)
+             (contextScope context)
+             (contextDataTypes context)
+             e' >>=
+             loopy string
+         else pure ())
+    ""
+    e0
 
 -- | Filter out expressions with intermediate case, if and immediately-applied lambdas.
 cleanExpression :: Expression Type i l -> Bool
@@ -124,109 +128,6 @@ cleanExpression =
     ApplicationExpression _ f x -> cleanExpression f && cleanExpression x
     _ -> True
 
-runTypeChecker
-  :: (MonadThrow m, MonadCatch m, MonadSupply Int m)
-  => [Decl UnkindedType Identifier Location]
-  -> m ([BindGroup Type Name (TypeSignature Type Name Location)]
-       ,Context Type Name Location)
-runTypeChecker decls =
-  let bindings =
-        mapMaybe
-          (\case
-             BindGroupDecl d -> Just d
-             _ -> Nothing)
-          decls
-      classes =
-        mapMaybe
-          (\case
-             ClassDecl d -> Just d
-             _ -> Nothing)
-          decls
-      instances =
-        mapMaybe
-          (\case
-             InstanceDecl d -> Just d
-             _ -> Nothing)
-          decls
-      types =
-        mapMaybe
-          (\case
-             DataDecl d -> Just d
-             _ -> Nothing)
-          decls
-  in do builtins <- setupEnv mempty
-        let specials = builtinsSpecials builtins
-        (typeClasses, signatures, subs, dataTypes) <-
-          do dataTypes <- renameDataTypes specials types
-             consSigs <-
-               fmap
-                 concat
-                 (mapM
-                    (dataTypeSignatures (builtinsSpecialTypes builtins))
-                    dataTypes)
-             typeClasses0 <-
-               mapM
-                 (\c -> do
-                    renamed <- renameClass specials mempty dataTypes c
-                    pure (className c, renamed))
-                 classes
-             let typeClasses = map snd typeClasses0
-             methodSigs <- fmap concat (mapM classSignatures typeClasses)
-             let signatures = builtinsSignatures builtins <> consSigs <> methodSigs
-                 subs =
-                   M.fromList
-                     (mapMaybe
-                        (\(TypeSignature name _) ->
-                           case name of
-                             ValueName _ ident -> Just (Identifier ident, name)
-                             ConstructorName _ ident ->
-                               pure (Identifier ident, name)
-                             MethodName _ ident -> pure (Identifier ident, name)
-                             _ -> Nothing)
-                        signatures) <>
-                   M.fromList (map (second className) typeClasses0)
-             allInstances <-
-               mapM
-                 (renameInstance specials subs dataTypes typeClasses)
-                 instances
-             pure
-               ( map
-                   (\typeClass ->
-                      typeClass
-                      { classInstances =
-                          filter
-                            ((== className typeClass) . instanceClassName)
-                            allInstances
-                      })
-                   typeClasses
-               , signatures
-               , subs
-               , dataTypes)
-        (renamedBindings, subs') <-
-          renameBindGroups specials subs dataTypes bindings
-        env <-
-          foldM
-            (\e0 typeClass ->
-               addClass typeClass e0 >>= \e ->
-                 foldM
-                   (\e1 i -> do addInstance i e1)
-                   e
-                   (classInstances typeClass))
-            (builtinsTypeClasses builtins)
-            typeClasses
-        (bindGroups, env') <-
-          typeCheckModule env signatures (builtinsSpecialTypes builtins) renamedBindings
-        return
-          ( bindGroups
-          , Context
-            { contextSpecialSigs = builtinsSpecialSigs builtins
-            , contextSpecialTypes = builtinsSpecialTypes builtins
-            , contextSignatures = signatures
-            , contextScope = subs'
-            , contextTypeClasses = env'
-            , contextDataTypes = dataTypes
-            })
-
 --------------------------------------------------------------------------------
 -- Setting the context
 

src/Duet/Context.hs

@@ -1,12 +1,17 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 -- | Functions for setting up the context.
 
 module Duet.Context where
 
+import           Control.Monad
 import           Control.Monad.Catch
 import           Control.Monad.Supply
+import           Data.List
 import qualified Data.Map.Strict as M
+import           Data.Maybe
+import           Data.Monoid
 import           Duet.Infer
 import           Duet.Renamer
 import           Duet.Supply
@@ -94,3 +99,87 @@ builtinsSpecials builtins =
 contextSpecials :: Context t i l -> Specials i
 contextSpecials context =
   Specials (contextSpecialSigs context) (contextSpecialTypes context)
+
+generateAllSignatures builtins dataTypes typeClasses =
+  do consSigs <-
+       fmap
+         concat
+         (mapM (dataTypeSignatures (builtinsSpecialTypes builtins)) dataTypes)
+     methodSigs <- fmap concat (mapM classSignatures typeClasses)
+     pure (builtinsSignatures builtins <> consSigs <> methodSigs)
+
+makeScope typeClasses signatures =
+  pure
+    (M.fromList
+       (mapMaybe
+          (\(TypeSignature name _) ->
+             case name of
+               ValueName _ ident -> Just (Identifier ident, name)
+               ConstructorName _ ident -> pure (Identifier ident, name)
+               MethodName _ ident -> pure (Identifier ident, name)
+               _ -> Nothing)
+          signatures) <>
+     M.map className typeClasses)
+
+renameEverything decls specials builtins = do
+  dataTypes <- renameDataTypes specials (declsDataTypes decls)
+  (typeClasses, signatures, subs) <-
+    do typeClasses <-
+         fmap
+           M.fromList
+           (mapM
+              (\c -> do
+                 renamed <- renameClass specials mempty dataTypes c
+                 pure (className c, renamed))
+              classes)
+       signatures <- generateAllSignatures builtins dataTypes typeClasses
+       scope <- makeScope typeClasses signatures
+       allInstances <-
+         mapM
+           (renameInstance specials scope dataTypes (M.elems typeClasses))
+           instances
+       pure
+         ( M.map
+             (\typeClass ->
+                typeClass
+                { classInstances =
+                    filter
+                      ((== className typeClass) . instanceClassName)
+                      allInstances
+                })
+             typeClasses
+         , signatures
+         , scope)
+  (renamedBindings, subs') <- renameBindGroups specials subs dataTypes bindings
+  pure (typeClasses, signatures, renamedBindings, subs', dataTypes)
+  where declsDataTypes =
+          mapMaybe
+            (\case
+               DataDecl d -> Just d
+               _ -> Nothing)
+        bindings =
+          mapMaybe
+            (\case
+               BindGroupDecl d -> Just d
+               _ -> Nothing)
+            decls
+        classes =
+          mapMaybe
+            (\case
+               ClassDecl d -> Just d
+               _ -> Nothing)
+            decls
+        instances =
+          mapMaybe
+            (\case
+               InstanceDecl d -> Just d
+               _ -> Nothing)
+            decls
+
+addClasses builtins typeClasses =
+  foldM
+    (\e0 typeClass ->
+       addClass typeClass e0 >>= \e ->
+         foldM (\e1 i -> do addInstance i e1) e (classInstances typeClass))
+    (builtinsTypeClasses builtins)
+    typeClasses

src/Duet/Parser.hs

@@ -10,6 +10,8 @@
 module Duet.Parser where
 
 import           Control.Monad
+import           Control.Monad.Catch
+import           Control.Monad.IO.Class
 import           Data.List
 import qualified Data.Map.Strict as M
 import           Data.Text (Text)
@@ -20,18 +22,19 @@ import           Duet.Tokenizer
 import           Duet.Types
 import           Text.Parsec hiding (satisfy, anyToken)
 
-parseFile :: FilePath -> IO (Either ParseError [Decl UnkindedType Identifier Location])
-parseFile fp = do t <- T.readFile fp
-                  return (parseText fp t)
+parseFile :: (MonadIO m, MonadThrow m) => FilePath -> m [Decl UnkindedType Identifier Location]
+parseFile fp = do
+  t <- liftIO (T.readFile fp)
+  parseText fp t
 
-parseText :: SourceName -> Text -> Either ParseError [Decl UnkindedType Identifier Location]
+parseText :: MonadThrow m => SourceName -> Text -> m [Decl UnkindedType Identifier Location]
 parseText fp inp =
   case parse tokensTokenizer fp (inp) of
-    Left e -> Left e
+    Left e -> throwM (TokenizerError e)
     Right tokens' ->
       case runParser tokensParser 0 fp tokens' of
-        Left e -> Left e
-        Right ast -> Right ast
+        Left e -> throwM (ParserError e)
+        Right ast -> pure ast
 
 parseType' :: Num u => SourceName -> Parsec [(Token, Location)] u b -> Text -> Either ParseError b
 parseType' fp p inp =

src/Duet/Renamer.hs

@@ -120,7 +120,7 @@ renameField specials typeConstructors vars name fe = do
       case find ((\(j, _, _, _) -> j == i)) typeConstructors of
         Just (_, name', vs, _) -> pure (name', vs)
         Nothing ->
-          case specialTypesBool (specialTypes specials) of
+          case specialTypesBool (specialsTypes specials) of
             DataType n@(TypeName _ i') vars _
               | Identifier i' == i ->
                 pure
@@ -131,7 +131,7 @@ renameField specials typeConstructors vars name fe = do
                            (Identifier i, TypeVariable n k))
                       vars)
             _ ->
-              case specialTypesFunction (specialTypes specials) of
+              case specialTypesFunction (specialsTypes specials) of
                 TypeConstructor n@(TypeName _ i') _
                   | Identifier i' == i -> do
                     vars <-
@@ -295,7 +295,7 @@ renameDict specials subs types (Dictionary _ methods) predicate = do
 
 predicateToDict :: Specials Name -> ((Predicate Type Name)) -> String
 predicateToDict specials pred =
-  "$dict" ++ map normalize (printPredicate defaultPrint (specialTypes specials) pred)
+  "$dict" ++ map normalize (printPredicate defaultPrint (specialsTypes specials) pred)
   where
     normalize c
       | isDigit c || isLetter c = c
@@ -389,8 +389,8 @@ renameType specials tyVars types t = either go pure (isType t)
               a' <- go a
               throwM (KindTooManyArgs f' (typeKind f') a')
     specials' =
-      [ setup (specialTypesFunction . specialTypes)
-      , setup (dataTypeToConstructor . specialTypesBool . specialTypes)
+      [ setup (specialTypesFunction . specialsTypes)
+      , setup (dataTypeToConstructor . specialTypesBool . specialsTypes)
       ]
       where
         setup f = do
@@ -561,7 +561,7 @@ renameExpression specials subs types = go
               Nothing -> do
                 ident <- identifyValue i
                 case lookup ident operatorTable of
-                  Just f -> pure (f (specialSigs specials))
+                  Just f -> pure (f (specialsSigs specials))
                   _ -> throwM (IdentifierNotInVarScope subs ident)
           InfixExpression l <$> go x <*> pure (orig, VariableExpression l0 i') <*>
             go y

src/Duet/Resolver.hs

@@ -9,15 +9,46 @@
 
 module Duet.Resolver where
 
-import Control.Monad.Catch
-import Control.Monad.Supply
-import Data.List
-import Data.Map.Strict (Map)
-import Data.Maybe
-import Duet.Infer
-import Duet.Printer
-import Duet.Supply
-import Duet.Types
+import           Control.Monad.Catch
+import           Control.Monad.Supply
+import           Data.List
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import           Data.Maybe
+import           Duet.Infer
+import           Duet.Printer
+import           Duet.Supply
+import           Duet.Types
+
+
+resolveTypeClasses
+  :: (Show l, MonadSupply Int f, MonadThrow f)
+  => Map Name (Class Type Name (TypeSignature Type Name l))
+  -> SpecialTypes Name
+  -> f (Map Name (Class Type Name (TypeSignature Type Name l)))
+resolveTypeClasses typeClasses specialTypes = go typeClasses
+  where
+    go =
+      fmap M.fromList .
+      mapM
+        (\(name, cls) -> do
+           is <-
+             mapM
+               (\inst -> do
+                  ms <-
+                    mapM
+                      (\(nam, alt) ->
+                         fmap (nam, ) (resolveAlt typeClasses specialTypes alt))
+                      (M.toList (dictionaryMethods (instanceDictionary inst)))
+                  pure
+                    inst
+                    { instanceDictionary =
+                        (instanceDictionary inst)
+                        {dictionaryMethods = M.fromList ms}
+                    })
+               (classInstances cls)
+           pure (name, cls {classInstances = is})) .
+      M.toList
 
 resolveBindGroup
   :: (MonadSupply Int m, MonadThrow m ,Show l)

src/Duet/Stepper.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE Strict #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -29,14 +30,14 @@ import           Duet.Types
 
 expandSeq1
   :: (MonadThrow m, MonadSupply Int m)
-  => Map Name (Class Type Name (TypeSignature Type Name Location))
-  -> SpecialSigs Name
-  -> [TypeSignature Type Name Name]
-  -> Expression Type Name (TypeSignature Type Name Location)
+  => Context Type Name (Location)
   -> [BindGroup Type Name (TypeSignature Type Name Duet.Types.Location)]
+  -> Expression Type Name (TypeSignature Type Name Location)
   -> m (Expression Type Name (TypeSignature Type Name Location))
-expandSeq1 typeClassEnv specialSigs signatures e b  =
-  evalStateT (go e) False
+expandSeq1 (Context { contextTypeClasses = typeClassEnv
+                    , contextSpecialSigs = specialSigs
+                    , contextSignatures = signatures
+                    }) b e = evalStateT (go e) False
   where
     go =
       \case
@@ -52,7 +53,7 @@ expandSeq1 typeClassEnv specialSigs signatures e b  =
             if alreadyExpanded
               then pure e0
               else do
-                e' <- lift (expandWhnf typeClassEnv specialSigs signatures e0 b )
+                e' <- lift (expandWhnf typeClassEnv specialSigs signatures e0 b)
                 put (e' /= e0)
                 pure e'
 

src/Duet/Types.hs

@@ -10,6 +10,7 @@
 
 module Duet.Types where
 
+import           Text.Parsec (ParseError)
 import           Control.Monad.Catch
 import           Control.Monad.State
 import           Data.Map.Strict (Map)
@@ -116,11 +117,16 @@ data InferState = InferState
   -- , inferStateExpressionTypes :: ![(Expression (), Scheme)]
   } deriving (Show)
 
+data ParseException
+  = TokenizerError ParseError
+  | ParserError ParseError
+ deriving (Typeable, Show)
+instance Exception ParseException
+
 data StepException
   = CouldntFindName !Name
   | CouldntFindNameByString !String
   | TypeAtValueScope !Name
-
   deriving (Typeable, Show)
 instance Exception StepException
 
@@ -480,6 +486,6 @@ data Token
   deriving (Eq, Ord)
 
 data Specials n = Specials
-  { specialSigs :: SpecialSigs n
-  , specialTypes :: SpecialTypes n
+  { specialsSigs :: SpecialSigs n
+  , specialsTypes :: SpecialTypes n
   }