haskell: some abstractions compile
This commit is contained in:
parent
0391cbcfab
commit
e21bb48b63
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -4,6 +4,7 @@
|
||||||
|
|
||||||
.#*
|
.#*
|
||||||
build
|
build
|
||||||
|
/haskell/**/dist-newstyle
|
||||||
/rust/target
|
/rust/target
|
||||||
result
|
result
|
||||||
result-*
|
result-*
|
||||||
|
|
64
haskell/nfker7h/lib/Language/Yanais/Fusion.hs
Normal file
64
haskell/nfker7h/lib/Language/Yanais/Fusion.hs
Normal file
|
@ -0,0 +1,64 @@
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
|
||||||
|
module Language.Yanais.Fusion (
|
||||||
|
Step(..),
|
||||||
|
stepState,
|
||||||
|
StepFun(..),
|
||||||
|
Stream,
|
||||||
|
embedTfs
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Bifunctor
|
||||||
|
import qualified Data.Text.Internal.Fusion as TF
|
||||||
|
|
||||||
|
data Step s a = Done | Skip !s | Yield !a !s
|
||||||
|
|
||||||
|
instance Functor (Step s) where
|
||||||
|
fmap _ Done = Done
|
||||||
|
fmap _ (Skip s) = Skip s
|
||||||
|
fmap f (Yield a s) = Yield (f a) s
|
||||||
|
|
||||||
|
instance Bifunctor Step where
|
||||||
|
bimap _ _ Done = Done
|
||||||
|
bimap f _ (Skip s) = Skip (f s)
|
||||||
|
bimap f g (Yield a s) = Yield (g a) (f s)
|
||||||
|
|
||||||
|
stepState :: Step s a -> Maybe s
|
||||||
|
stepState Done = Nothing
|
||||||
|
stepState (Skip st) = Just st
|
||||||
|
stepState (Yield _ st) = Just st
|
||||||
|
|
||||||
|
data StepFun s a = StepFun (s -> Step s a)
|
||||||
|
|
||||||
|
instance Functor (StepFun s) where
|
||||||
|
fmap f inif = inif >>= (\x -> pure (f x))
|
||||||
|
|
||||||
|
instance Applicative (StepFun s) where
|
||||||
|
pure x = StepFun (\st -> Yield x st)
|
||||||
|
|
||||||
|
f <*> v = f >>= (\fx -> v >>= (\vx -> StepFun $ Yield (fx vx)))
|
||||||
|
|
||||||
|
instance Monad (StepFun s) where
|
||||||
|
return = pure
|
||||||
|
(StepFun f1) >>= f2 = StepFun go
|
||||||
|
where
|
||||||
|
go st = case f1 st of
|
||||||
|
Done -> Done
|
||||||
|
Skip st2 -> Skip st2
|
||||||
|
Yield x st2 -> let (StepFun f3) = (f2 x) in f3 st2
|
||||||
|
|
||||||
|
data Stream a = forall s. Stream
|
||||||
|
(StepFun s a) -- stepper function
|
||||||
|
!s -- current state
|
||||||
|
|
||||||
|
instance Functor Stream where
|
||||||
|
fmap f (Stream step cst) = Stream (fmap f step) cst
|
||||||
|
|
||||||
|
smap :: TF.Step s a -> Step s a
|
||||||
|
smap TF.Done = Done
|
||||||
|
smap (TF.Skip st) = Skip st
|
||||||
|
smap (TF.Yield av st) = Yield av st
|
||||||
|
|
||||||
|
embedTfs :: TF.Stream x -> Stream x
|
||||||
|
embedTfs (TF.Stream step st _) = Stream (StepFun (smap . step)) st
|
|
@ -1,54 +0,0 @@
|
||||||
module Language.Yanais.Nfker7h.Parser.Fusion (
|
|
||||||
Step(*),
|
|
||||||
StepFun(*),
|
|
||||||
Stream,
|
|
||||||
embedTfs
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Bifunctor
|
|
||||||
import Data.Text.Internal.Fusion as TF
|
|
||||||
import Prolens
|
|
||||||
|
|
||||||
data Step s a = Done | Skip !s | Yield !a !s
|
|
||||||
|
|
||||||
instance Functor (Step s) where
|
|
||||||
fmap f Done = Done
|
|
||||||
fmap f (Skip s) = Skip s
|
|
||||||
fmap f (Yield a s) = Yield (f a) s
|
|
||||||
|
|
||||||
instance Bifunctor Step where
|
|
||||||
bimap f g Done = Done
|
|
||||||
bimap f g (Skip s) = Skip (f s)
|
|
||||||
bimap f g (Yield a s) = Yield (g a) (f s)
|
|
||||||
|
|
||||||
data StepFun s a = StepFun (s -> Step s a)
|
|
||||||
|
|
||||||
instance Functor (StepFun s) where
|
|
||||||
fmap f inif = inif >>= (\x -> pure (f x))
|
|
||||||
|
|
||||||
instance Applicative (StepFun s) where
|
|
||||||
pure x = StepFun (\st -> Yield st x)
|
|
||||||
f <*> v = f >>= (\fx -> v >>= (\vx -> StepFun (\st -> fx vx)))
|
|
||||||
|
|
||||||
instance Monad (StepFun s) where
|
|
||||||
return = pure
|
|
||||||
(StepFun f1) >>= f2 = StepFun go
|
|
||||||
where
|
|
||||||
go st = case f1 st of
|
|
||||||
Done -> Done
|
|
||||||
Skip st2 -> Skip st2
|
|
||||||
Yield x st2 -> f2 x st2
|
|
||||||
|
|
||||||
liftLens :: Lens' source a -> Lens' (StepFun
|
|
||||||
|
|
||||||
data StreamInner s a = StreamInner
|
|
||||||
(StepFun s a) -- stepper function
|
|
||||||
!s -- current state
|
|
||||||
|
|
||||||
type Stream a = forall s. StreamInner s a
|
|
||||||
|
|
||||||
instance Functor (StreamInner s) where
|
|
||||||
fmap f (Stream step cst) = Stream (fmap f step) cst
|
|
||||||
|
|
||||||
embedTfs :: TF.Stream x -> Stream x
|
|
||||||
embedTfs (TF.Stream step st) = Stream (StepFun step) st
|
|
|
@ -2,15 +2,15 @@
|
||||||
|
|
||||||
module Language.Yanais.Nfker7h.Parser.Lex (
|
module Language.Yanais.Nfker7h.Parser.Lex (
|
||||||
Token,
|
Token,
|
||||||
TokenKind(*),
|
TokenKind(..),
|
||||||
Keyword(*),
|
Keyword(..),
|
||||||
lex,
|
lex,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Either (Either(*))
|
import Data.Either (Either(..))
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Text.ICU.Char (Bool_, property)
|
import Data.Text.ICU.Char (Bool_, property)
|
||||||
import Data.Text.Internal.Fusion as TF
|
import Data.Text.Internal.Fusion as TF
|
||||||
|
@ -49,6 +49,8 @@ data Lexer = Lexer {
|
||||||
|
|
||||||
type LexerMonad a = StateT !Int (Either (Span, Error) a)
|
type LexerMonad a = StateT !Int (Either (Span, Error) a)
|
||||||
|
|
||||||
|
type LexerStep = Lexer -> Step Lexer Char
|
||||||
|
|
||||||
lex :: T.Text -> Stream (Either (Span, Error) Token)
|
lex :: T.Text -> Stream (Either (Span, Error) Token)
|
||||||
lex t = Stream step (Lexer { lexOffset = 0, lexS = liftTfs (stream t) })
|
lex t = Stream step (Lexer { lexOffset = 0, lexS = liftTfs (stream t) })
|
||||||
where
|
where
|
||||||
|
@ -56,7 +58,8 @@ lex t = Stream step (Lexer { lexOffset = 0, lexS = liftTfs (stream t) })
|
||||||
stepi lxr = first (\st -> lxr { lexS = st }) (lexS lxr)
|
stepi lxr = first (\st -> lxr { lexS = st }) (lexS lxr)
|
||||||
step :: Lexer -> Step Lexer (Either (Span, Error) Token)
|
step :: Lexer -> Step Lexer (Either (Span, Error) Token)
|
||||||
|
|
||||||
|
-- sublexers
|
||||||
|
lexString
|
||||||
|
|
||||||
lex :: T.Text -> LexerMonad [Token]
|
lex :: T.Text -> LexerMonad [Token]
|
||||||
lex t = T.foldl' (return []) go t
|
lex t = T.foldl' (return []) go t
|
||||||
|
|
|
@ -1,15 +1,18 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
module Language.Yanais.Nfker7h.Parser.Types (
|
module Language.Yanais.Nfker7h.Parser.Types (
|
||||||
Span(*),
|
Span(..),
|
||||||
Ident,
|
Ident,
|
||||||
Context(*),
|
Context(..),
|
||||||
Result(*),
|
Result(..),
|
||||||
Error(*),
|
Error(..),
|
||||||
MaybeGetSpan
|
MaybeGetSpan
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.DeepSeq (NFData)
|
import Control.DeepSeq (NFData)
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import Generic.Data
|
||||||
|
|
||||||
-- A 0-indexed, half-open interval of integers, defined by start & end indices
|
-- A 0-indexed, half-open interval of integers, defined by start & end indices
|
||||||
data Span = Span
|
data Span = Span
|
||||||
|
@ -24,17 +27,14 @@ instance NFData Span
|
||||||
instance Semigroup Span where
|
instance Semigroup Span where
|
||||||
Span start1 end1 <> Span start2 end2 = Span (min start1 start2) (max end1 end2)
|
Span start1 end1 <> Span start2 end2 = Span (min start1 start2) (max end1 end2)
|
||||||
|
|
||||||
instance Lower Span where
|
data Ident = Ident T.Text
|
||||||
lowerBound = Span 0 0
|
|
||||||
|
|
||||||
type Ident = Ident T.Text
|
|
||||||
|
|
||||||
-- a "classic" tristate result
|
-- a "classic" tristate result
|
||||||
type Result t = RSome t | RNone | RError Span Error
|
data Result t = RSome t | RNone | RError Span Error
|
||||||
|
|
||||||
type Context = CtxModule
|
data Context = CtxModule
|
||||||
|
|
||||||
type Error = UnexpectedEof Context
|
data Error = UnexpectedEof Context
|
||||||
| UnknownIdent Ident
|
| UnknownIdent Ident
|
||||||
|
|
||||||
instance Functor Result where
|
instance Functor Result where
|
||||||
|
@ -61,9 +61,15 @@ class MaybeGetSpan a where
|
||||||
|
|
||||||
instance MaybeGetSpan t => MaybeGetSpan (Result t) where
|
instance MaybeGetSpan t => MaybeGetSpan (Result t) where
|
||||||
mgSpan (RSome x) = mgSpan x
|
mgSpan (RSome x) = mgSpan x
|
||||||
mgSpan RNone = None
|
mgSpan RNone = Nothing
|
||||||
mgSpan (RError s _) = Just s
|
mgSpan (RError s _) = Just s
|
||||||
|
|
||||||
|
instance Show Ident where
|
||||||
|
show (Ident x) = show x
|
||||||
|
|
||||||
|
instance Show Context where
|
||||||
|
show CtxModule = "module level"
|
||||||
|
|
||||||
instance Show Error where
|
instance Show Error where
|
||||||
show (UnexpectedEof ctx) = "end of file encountered inside " <> show ctx
|
show (UnexpectedEof ctx) = "end of file encountered inside " <> show ctx
|
||||||
show (UnknownIdent x) = "unknown identifier " <> show x
|
show (UnknownIdent x) = "unknown identifier " <> show x
|
||||||
|
|
|
@ -52,30 +52,37 @@ extra-doc-files: CHANGELOG.md
|
||||||
-- extra-source-files:
|
-- extra-source-files:
|
||||||
|
|
||||||
common warnings
|
common warnings
|
||||||
ghc-options: -Wall
|
ghc-options: -W -Wall
|
||||||
|
|
||||||
library
|
library
|
||||||
-- Import common warning flags.
|
-- Import common warning flags.
|
||||||
import: warnings
|
import: warnings
|
||||||
|
|
||||||
-- Modules exported by the library.
|
-- Modules exported by the library.
|
||||||
exposed-modules: Language.Yanais.Nfker7h.Parser.Lex
|
exposed-modules:
|
||||||
|
Language.Yanais.Fusion
|
||||||
|
, Language.Yanais.Nfker7h.Parser.Types
|
||||||
|
, Language.Yanais.Nfker7h.Parser.Lex
|
||||||
|
|
||||||
-- Modules included in this library but not exported.
|
-- Modules included in this library but not exported.
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
|
|
||||||
-- LANGUAGE extensions used by modules in this package.
|
-- LANGUAGE extensions used by modules in this package.
|
||||||
-- other-extensions:
|
other-extensions:
|
||||||
|
DeriveGeneric
|
||||||
|
ExistentialQuantification
|
||||||
|
OverloadedStrings
|
||||||
|
RankNTypes
|
||||||
|
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends:
|
build-depends:
|
||||||
base ^>= 4.17.2.0
|
base ^>= 4.17.2.0
|
||||||
deepseq (>= 1.1 && <1.6)
|
, deepseq (>= 1.1 && <1.6)
|
||||||
mtl ^>= 2.3.1
|
, generic-data ^>= 1.1.0.0
|
||||||
prolens ^>= 0.0.0.0
|
, hashable ^>= 1.4.3.0
|
||||||
semilattices (>= 0.0.0.3 && <0.1)
|
, mtl ^>= 2.3.1
|
||||||
text ^>= 2.1
|
, text ^>= 2.1
|
||||||
text-icu ^>= 0.8.0.0
|
, text-icu ^>= 0.8.0.0
|
||||||
|
|
||||||
-- build-tools: alex
|
-- build-tools: alex
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue