Skip to content

Commit

Permalink
Generalize CodeGen to use it for other targets (nirum-lang#67)
Browse files Browse the repository at this point in the history
* [WIP]

* Replace CodeGen with StateT to contain context properly

* Fix 'fail' method of (CodeGen a)

* [WIP]

* Generalize CodeGen
  • Loading branch information
Kroisse authored and dahlia committed Aug 24, 2016
1 parent c9c0fb6 commit 0666b8d
Show file tree
Hide file tree
Showing 5 changed files with 290 additions and 260 deletions.
4 changes: 4 additions & 0 deletions nirum.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ cabal-version: >=1.10

library
exposed-modules: Nirum.Cli
, Nirum.CodeGen
, Nirum.Constructs
, Nirum.Constructs.Annotation
, Nirum.Constructs.Annotation.Internal
Expand All @@ -43,6 +44,7 @@ library
, filepath >=1.4 && <1.5
, interpolatedstring-perl6 >=1.0.0 && <1.1.0
, megaparsec >=5 && <5.1
, mtl >=2.2.1 && <3
, semver >=0.3.0 && <1.0
, text >=0.9.1.0 && <1.3
hs-source-dirs: src
Expand Down Expand Up @@ -72,6 +74,7 @@ test-suite spec
hs-source-dirs: test
main-is: Spec.hs
other-modules: Nirum.CliSpec
, Nirum.CodeGenSpec
, Nirum.Constructs.AnnotationSpec
, Nirum.Constructs.DocsSpec
, Nirum.Constructs.DeclarationSetSpec
Expand All @@ -98,6 +101,7 @@ test-suite spec
, hspec-meta
, interpolatedstring-perl6 >=1.0.0 && <1.1.0
, megaparsec >=5 && <5.1
, mtl >=2.2.1 && <3
, nirum
, process >=1.1 && <2
, semigroups
Expand Down
42 changes: 42 additions & 0 deletions src/Nirum/CodeGen.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,42 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
module Nirum.CodeGen ( CodeGen
, Failure
, fromString
, runCodeGen
) where

import Control.Applicative (Applicative)
import Control.Monad (Monad)
import Control.Monad.Except (MonadError, ExceptT(ExceptT), mapExceptT, runExceptT)
import Control.Monad.State (MonadState, State, mapState, runState)
import Data.Functor (Functor)


newtype CodeGen s e a = CodeGen (ExceptT e (State s) a)
deriving ( Applicative
, Functor
, MonadError e
, MonadState s
)

class Failure s a where
fromString :: MonadState s m => String -> m a

instance (Failure s e) => Monad (CodeGen s e) where
return a = CodeGen $ ExceptT $ return (Right a)
{-# INLINE return #-}
(CodeGen m) >>= k = CodeGen $ ExceptT $ do
a <- runExceptT m
case a of
Left e -> return (Left e)
Right x -> let CodeGen n = k x in runExceptT n
{-# INLINE (>>=) #-}
fail str = CodeGen $ mapExceptT mutate (fromString str)
where
mutate = mapState (\(a, s) -> case a of
Left _ -> undefined
Right e -> (Left e, s))
{-# INLINE fail #-}

runCodeGen :: CodeGen s e a -> s -> (Either e a, s)
runCodeGen (CodeGen a) = runState (runExceptT a)
Loading

0 comments on commit 0666b8d

Please sign in to comment.