Stack-ify the project.

Setup.hs

@@ -0,0 +1,5 @@
+import Prelude
+import Distribution.Extra.Doctest (defaultMainWithDoctests)
+
+main :: IO ()
+main = defaultMainWithDoctests "doctests"

bin/Clash.hs

@@ -0,0 +1,7 @@
+
+import Prelude
+import System.Environment (getArgs)
+import Clash.Main (defaultMain)
+
+main :: IO ()
+main = getArgs >>= defaultMain

bin/Clashi.hs

@@ -0,0 +1,7 @@
+
+import Prelude
+import System.Environment (getArgs)
+import Clash.Main (defaultMain)
+
+main :: IO ()
+main = getArgs >>= defaultMain . ("--interactive":)

cabal.project

@@ -0,0 +1,11 @@
+packages:
+  clashfsm.cabal
+
+package clash-prelude
+  -- 'large-tuples' generates tuple instances for various classes up to the
+  -- GHC imposed maximum of 62 elements. This severely slows down compiling
+  -- Clash, and triggers Template Haskell bugs on Windows. Hence, we disable
+  -- it by default. This will be the default for Clash >=1.4.
+  flags: -large-tuples
+
+write-ghc-environment-files: always

clashfsm.cabal

@@ -0,0 +1,146 @@
+cabal-version:       2.4
+name:                clashfsm
+version:             0.1
+license:             BSD-2-Clause
+author:              John Smith <[email protected]>
+maintainer:          John Smith <[email protected]>
+
+common common-options
+  default-extensions:
+    BangPatterns
+    BinaryLiterals
+    ConstraintKinds
+    DataKinds
+    DefaultSignatures
+    DeriveAnyClass
+    DeriveDataTypeable
+    DeriveFoldable
+    DeriveFunctor
+    DeriveGeneric
+    DeriveLift
+    DeriveTraversable
+    DerivingStrategies
+    InstanceSigs
+    KindSignatures
+    LambdaCase
+    NoStarIsType
+    PolyKinds
+    RankNTypes
+    ScopedTypeVariables
+    StandaloneDeriving
+    TupleSections
+    TypeApplications
+    TypeFamilies
+    TypeOperators
+    ViewPatterns
+
+    -- TemplateHaskell is used to support convenience functions such as
+    -- 'listToVecTH' and 'bLit'.
+    TemplateHaskell
+    QuasiQuotes
+
+    -- Prelude isn't imported by default as Clash offers Clash.Prelude
+    NoImplicitPrelude
+  ghc-options:
+    -Wall -Wcompat
+    -haddock
+
+    -- Plugins to support type-level constraint solving on naturals
+    -fplugin GHC.TypeLits.Extra.Solver
+    -fplugin GHC.TypeLits.Normalise
+    -fplugin GHC.TypeLits.KnownNat.Solver
+
+    -- Clash needs access to the source code in compiled modules
+    -fexpose-all-unfoldings
+
+    -- Worker wrappers introduce unstable names for functions that might have
+    -- blackboxes attached for them. You can disable this, but be sure to add
+    -- a no-specialize pragma to every function with a blackbox.
+    -fno-worker-wrapper
+  build-depends:
+    base,
+    Cabal,
+    template-haskell,
+    containers >= 0.6 && < 0.7,
+    trifecta >= 2.1 && < 2.2,
+    parsers >= 0.12 && < 0.13,
+    unordered-containers >= 0.2 && < 0.3,
+    haskell-src-meta >= 0.8 && < 0.9,
+    prettyprinter >= 1.7 && < 1.8,
+    mtl >= 2.2 && < 2.3,
+    lens >= 4.19 && < 4.20,
+
+    -- clash-prelude will set suitable version bounds for the plugins
+    clash-prelude >= 1.2.5 && < 1.6,
+    ghc-typelits-natnormalise,
+    ghc-typelits-extra,
+    ghc-typelits-knownnat
+
+
+custom-setup
+  setup-depends:
+    base          >= 4.11 && <5,
+    Cabal         >= 2.4,
+    cabal-doctest >= 1.0.1 && <1.1
+
+library
+  import: common-options
+  hs-source-dirs: src
+  exposed-modules:
+    FSM,
+    FSMDesc,
+    FSMDescGenADT,
+    FSMFreeVars,
+    FSMLang,
+    FSMLang2Desc,
+    FSMLangParser,
+    FSMLangPretty,
+    FSMLangProcess
+  default-language: Haskell2010
+
+-- Builds the executable 'clash', with clashfsm project in scope
+executable clash
+  main-is: bin/Clash.hs
+  default-language: Haskell2010
+  Build-Depends: base, clash-ghc, clashfsm
+  if !os(Windows)
+    ghc-options: -dynamic
+
+-- Builds the executable 'clashi', with clashfsm project in scope
+executable clashi
+  main-is: bin/Clashi.hs
+  default-language: Haskell2010
+  if !os(Windows)
+    ghc-options: -dynamic
+  build-depends: base, clash-ghc, clashfsm
+
+-- test-suite doctests
+--   import:           common-options
+--   type:             exitcode-stdio-1.0
+--   default-language: Haskell2010
+--   main-is:          doctests.hs
+--   hs-source-dirs:   tests
+-- 
+--   build-depends:
+--     base,
+--     clashfsm,
+--     process,
+--     doctest >= 0.16.1 && < 0.18
+-- 
+-- test-suite test-library
+--   import: common-options
+--   default-language: Haskell2010
+--   hs-source-dirs: tests
+--   type: exitcode-stdio-1.0
+--   ghc-options: -threaded
+--   main-is: unittests.hs
+--   other-modules:
+--     Tests.Example.Project
+--   build-depends:
+--     clashfsm,
+--     QuickCheck,
+--     hedgehog,
+--     tasty >= 1.2 && < 1.3,
+--     tasty-hedgehog,
+--     tasty-th
+

FSMFreeVars.hs → src/FSMFreeVars.hs

@@ -32,8 +32,8 @@ freeVarsExp (TH.UInfixE e1 e e2) = freeVarsExp e `S.union` freeVarsExp e1 `S.uni
 freeVarsExp (TH.ParensE e) = freeVarsExp e
 freeVarsExp (TH.LamE ps e) = freeVarsExp e `underPat` patUnions (map freeVarsPat ps)
 freeVarsExp (TH.LamCaseE ms) = S.unions $ map freeVarsMatch ms
-freeVarsExp (TH.TupE es) = S.unions $ map freeVarsExp es
-freeVarsExp (TH.UnboxedTupE es) = S.unions $ map freeVarsExp es
+freeVarsExp (TH.TupE es) = S.unions $ map freeVarsExpMaybe es
+freeVarsExp (TH.UnboxedTupE es) = S.unions $ map freeVarsExpMaybe es
 freeVarsExp (TH.UnboxedSumE e _ _) = freeVarsExp e
 freeVarsExp (TH.CondE e e1 e2) = freeVarsExp e `S.union` freeVarsExp e1 `S.union` freeVarsExp e2
 -- MultiIfE

FSMLangParser.hs → src/FSMLangParser.hs

@@ -16,12 +16,14 @@ import qualified Data.Map.Strict as M
 e2m (Left s) = fail s
 e2m (Right r) = return r
 
+newlineOrEof :: Parser ()
 newlineOrEof = (newline *> return ()) <|> eof
 
 ssymbol s = (try $ whiteSpace *> symbol s) <?> s
 
 stringToHsExp s = HM.toExp <$> HM.parseHsExp s
 stringToHsPat s = HM.toPat <$> HM.parseHsPat s
+parseToEOL :: ([Char] -> Either String a) -> Parser a
 parseToEOL p = e2m . p =<< manyTill anyChar newlineOrEof
 parseHsExpToEOL = parseToEOL stringToHsExp
 parseHsPatToEOL = parseToEOL stringToHsPat
@@ -32,21 +34,27 @@ singleSymbol s = runUnlined (ssymbol s) *> newlineOrEof
 
 parseName = TH.mkName <$> ident idStyle
 
+parseVar :: Parser Stmt
 parseVar = SVar <$> runUnlined (ssymbol "var" *> parseName <* symbolic '=')
                 <*> parseVStmt
                 <*> parseBasicStmt
 
+parseAssign :: Parser Stmt
 parseAssign = SAssign <$> runUnlined (parseName <* symbolic '=')
                       <*> parseHsExpToEOL
 
+parseLet :: Parser Stmt
 parseLet = SLet <$> runUnlined (ssymbol "let" *> parseName <* symbolic '=')
                 <*> parseVStmt
                 <*> parseBasicStmt
 
+parseEmit :: Parser Stmt
 parseEmit = SEmit <$> (runUnlined (ssymbol "emit") *> parseHsExpToEOL)
 
+parseRet :: Parser Stmt
 parseRet = SRet <$> (runUnlined (ssymbol "ret") *> parseVStmt)
 
+parseIf :: Parser Stmt
 parseIf = SIf <$> (runUnlined (ssymbol "if") *> parseHsExpToEOL)
               <*> parseBasicStmt
               <*> ((singleSymbol "else" *> parseBasicStmt) <|> return SNop)
@@ -56,19 +64,24 @@ parseFun1 = f <$> runUnlined (ssymbol "fun" *> parseName)
               <*> parseBasicStmt
     where f a b c = (a, (b, c))
 
+parseFun :: Parser Stmt
 parseFun = SFun <$> (M.fromList <$> some parseFun1)
                 <*> parseBasicStmt
 
+parseBlock :: Parser Stmt
 parseBlock = SBlock <$> (singleSymbol "begin" *> parseStmt <* singleSymbol "end")
 
+parseCase :: Parser Stmt
 parseCase = SCase <$> (runUnlined (ssymbol "case") *> parseHsExpToEOL)
                   <*> some parseCase1
 
 parseCase1 = (,) <$> (runUnlined (ssymbol "|") *> parseHsPatToEOL)
                  <*> parseBasicStmt
 
+parseNop :: Parser Stmt
 parseNop = singleSymbol "nop" *> return SNop
 
+parseBasicStmt :: Parser Stmt
 parseBasicStmt = parseVar
              <|> parseLet
              <|> parseEmit
@@ -80,13 +93,17 @@ parseBasicStmt = parseVar
              <|> parseNop
              <|> parseAssign
 
+parseStmt :: Parser [Stmt]
 parseStmt = many parseBasicStmt
 
+parseVCall :: Parser VStmt
 parseVCall = VCall <$> runUnlined (ssymbol "call" *> parseName)
                    <*> parseHsExpToEOL
 
+parseVExp :: Parser VStmt
 parseVExp = VExp <$> parseHsExpToEOL
 
+parseVStmt :: Parser VStmt
 parseVStmt = parseVCall
          <|> parseVExp
 

FSMLangProcess.hs → src/FSMLangProcess.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving, DerivingStrategies #-}
+{-# LANGUAGE TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving, DerivingStrategies, FlexibleContexts #-}
 module FSMLangProcess where
 
 import FSMLang
@@ -131,12 +131,14 @@ data CBData = CBData {
 
 $(makeLenses ''CBData)
 
+tupE = TH.TupE . map Just
+
 makeCont s = do
     CBData fv n <- ask
     let vs = S.toList $ freeVarsStmt s `S.difference` fv
     n' <- refreshName n
     modify $ M.insert n' (TH.TupP $ map TH.VarP vs, s)
-    return $ SRet (VCall n' (TH.TupE $ map TH.VarE vs))
+    return $ SRet (VCall n' (tupE $ map TH.VarE vs))
 
 cutBlocksStmt :: (MonadRefresh m, MonadState FunMap m, MonadReader CBData m) => Stmt -> Stmt -> m Stmt
 cutBlocksStmt SNop s' = return s'
@@ -306,17 +308,17 @@ makeTailCallsStmt   (SLet n (VCall f e) (SRet (VExp e'))) = do
     let vs = S.toList $ freeVarsExp e' `S.difference` S.insert n fvs
     cn <- refreshNameWithPrefix "C" f
     tell [ContData cn fn f n vs e' (ContTgtCont an)]
-    return $ SRet (VCall f (TH.TupE [e, TH.AppE (TH.ConE cn) (TH.TupE $ map TH.VarE $ cfn : vs)]))
+    return $ SRet (VCall f (tupE [e, TH.AppE (TH.ConE cn) (tupE $ map TH.VarE $ cfn : vs)]))
 makeTailCallsStmt   (SLet n (VCall f e) (SRet (VCall f' e'))) = do
     TCData _ _ _ fvs fn <- ask
     let vs = S.toList $ freeVarsExp e' `S.difference` S.insert n fvs
     cn <- refreshNameWithPrefix "C" f
     tell [ContData cn fn f n vs e' (ContTgtFun f')]
-    return $ SRet (VCall f (TH.TupE [e, TH.AppE (TH.ConE cn) (TH.TupE $ map TH.VarE vs)]))
+    return $ SRet (VCall f (tupE [e, TH.AppE (TH.ConE cn) (tupE $ map TH.VarE vs)]))
 makeTailCallsStmt   (SLet n (VExp e) s) = SLet n (VExp e) <$> makeTailCallsStmt s -- TODO freevars
 makeTailCallsStmt   (SIf e st sf) = SIf e <$> makeTailCallsStmt st <*> makeTailCallsStmt sf
 makeTailCallsStmt   (SCase e cs) = SCase e <$> mapM (\(p, s) -> (p,) <$> makeTailCallsStmt s) cs
-makeTailCallsStmt   (SRet (VExp e)) = SRet <$> (VCall <$> asks tcDataApply <*> ((\cfn -> TH.TupE [e, TH.VarE cfn]) <$> asks tcDataCont))
+makeTailCallsStmt   (SRet (VExp e)) = SRet <$> (VCall <$> asks tcDataApply <*> ((\cfn -> tupE [e, TH.VarE cfn]) <$> asks tcDataCont))
 makeTailCallsStmt s@(SRet (VCall _ _)) = return s
 makeTailCallsStmt   (SBlock [SEmit e,s]) = (\s' -> SBlock [SEmit e, s']) <$> makeTailCallsStmt s
 
@@ -353,7 +355,7 @@ makeTailCalls (NProg is fs f1 e1 cs) = do
                 ContTgtCont rap -> do
                     rcn <- makeName "rc"
                     return (TH.ConP (contDataConName cd) [TH.TupP $ map TH.VarP $ rcn : contDataVars cd],
-                        SLet (contDataResName cd) (VExp $ TH.VarE rn) $ SRet (VCall rap (TH.TupE [contDataExp cd, TH.VarE rcn])))
+                        SLet (contDataResName cd) (VExp $ TH.VarE rn) $ SRet (VCall rap (tupE [contDataExp cd, TH.VarE rcn])))
             return (an, (TH.TupP [TH.VarP rn, TH.VarP cfn], SCase (TH.VarE cfn) cs))
         | otherwise = return (an, (TH.TupP [], SNop)) -- will be cleaned up anyway
     cdef cdmap ((ctn, an), (n, _)) 

stack.yaml

@@ -0,0 +1,11 @@
+resolver: lts-17.13
+
+extra-deps:
+  # At the time of writing, no snapshot includes Clash 1.4 yet so we add it - and
+  # its dependencies - manually.
+  - lazysmallcheck-0.6
+  - Stream-0.4.7.2
+  - arrows-0.4.4.2
+  - clash-prelude-1.4.2
+  - clash-lib-1.4.2
+  - clash-ghc-1.4.2