Commit dd2d8122 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Adapt the 'definitive-base' library to allow cross-compiling towards a...

Adapt the 'definitive-base' library to allow cross-compiling towards a JavaScript runtime with the Haste compiler
parent ca90b313
......@@ -94,6 +94,8 @@ hasteDict = cocDict ("0.8.1.2-js" :: String) getString getBytes setString setByt
main :: IO ()
main = JS.concurrent $ void $ do
JS.wait 200
let runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
foldr (\w tl -> do
x <- runExtraState (getl endState)
......
......@@ -310,7 +310,11 @@ runCOCBuiltin COCB_InsertNodeDir = do
st -> st
type MaxDelta = Int
data UniverseConstraints = UniverseConstraints MaxDelta [MaxDelta]
type UniverseConstraint = [Maybe MaxDelta]
data UniverseConstraints = UniverseConstraints [UniverseConstraint]
instance Semigroup UniverseConstraints where
UniverseConstraints x + UniverseConstraints y = UniverseConstraints $ zipWith (zipWith (\_x _y -> zipWith max _x _y + _x + _y)) x y
instance Monoid UniverseConstraints where zero = UniverseConstraints (repeat (repeat Nothing))
data COCValue io str = COCExpr Int (Node str)
| COCNull | COCError str
| COCDir (NodeDir str ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
......
......@@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md
cabal-version: >=1.10
library
exposed-modules: Definitive, Algebra.Monad, Algebra.Functor, Algebra.Foldable, Algebra.Lens, Algebra.Subtractive, Algebra.Core, Algebra.Classes, Algebra.Traversable, Algebra.Applicative, Algebra.Arrow, Algebra.Monad.Error, Algebra.Monad.Foldable, Algebra.Monad.RWS, Algebra.Monad.Free, Algebra.Monad.State, Algebra.Monad.Writer, Algebra.Monad.Logic, Algebra.Monad.Base, Algebra.Monad.Cont, Algebra.Monad.Reader, Definitive.Base, Data.Containers, Data.Queue, Data.IOVar, Data.Probability, Data.TimeVal, Data.SExpr, Data.Containers.Sequence, IO.Time
exposed-modules: Definitive, Algebra.Monad, Algebra.Functor, Algebra.Foldable, Algebra.Lens, Algebra.Subtractive, Algebra.Core, Algebra.Classes, Algebra.Traversable, Algebra.Applicative, Algebra.Arrow, Algebra.Monad.Error, Algebra.Monad.Foldable, Algebra.Monad.RWS, Algebra.Monad.Free, Algebra.Monad.State, Algebra.Monad.Writer, Algebra.Monad.Logic, Algebra.Monad.Base, Algebra.Monad.Cont, Algebra.Monad.Reader, Definitive.Base, Data.Containers, Data.IOVar, Data.Probability, Data.TimeVal, Data.SExpr, Data.Containers.Sequence
-- other-modules:
default-extensions: TypeSynonymInstances,
NoMonomorphismRestriction,
......@@ -33,6 +33,9 @@ library
AllowAmbiguousTypes,
RoleAnnotations
other-extensions: ImplicitParams, StandaloneDeriving, MultiParamTypeClasses, RankNTypes, DefaultSignatures, TupleSections, Rank2Types, FunctionalDependencies, ViewPatterns, LiberalTypeSynonyms, NoRebindableSyntax, EmptyDataDecls, CPP, ScopedTypeVariables, UndecidableInstances, DeriveGeneric, ExistentialQuantification, RecursiveDo, DeriveDataTypeable
build-depends: base >=4.9 && <4.10,bytestring >=0.10 && <0.11,clock >=0.7 && <0.8,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5,vector >=0.12 && <0.13
build-depends: base >=4.8 && <4.10,bytestring >=0.10 && <0.11,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5
if !impl(haste)
build-depends: clock >=0.7 && <0.8,vector >=0.12 && <0.13
exposed-modules: IO.Time, Data.Queue
hs-source-dirs: src
default-language: Haskell2010
......@@ -97,6 +97,13 @@ instance SemiApplicative (Zip []) where
zip_ _ _ = []
instance Applicative (Zip []) where
instance Unit (Zip Maybe) where
pure a = Zip (Just a)
instance SemiApplicative (Zip Maybe) where
Zip (Just zf) <*> Zip (Just zx) = Zip (Just (zf zx))
_ <*> _ = Zip Nothing
instance Applicative (Zip Maybe)
instance Unit (Zip Tree) where
pure a = Zip (Node a (deZip (pure (pure a))))
instance SemiApplicative (Zip Tree) where
......
{-# LANGUAGE DefaultSignatures, ScopedTypeVariables, CPP #-}
#if MIN_VERSION_base(4,9,0)
#if MIN_VERSION_base(4,8,0)
{-# LANGUAGE TypeFamilies #-}
#endif
module Algebra.Classes where
......
......@@ -2,14 +2,16 @@
module Data.Containers.Sequence (
Sequence(..),Stream(..),i'elems,take,drop,dropping,
takeWhile,takeUntil,dropWhile,dropUntil,pry,
span,break,
(++),
#ifndef __HASTE__
-- * Strict and lazy slices (bytestrings on arbitrary Storable types)
Slice,Slices,slice,slices,i'storables,_Slices,breadth,
V.unsafeWith,sliceElt,span,break,
takeWhile,takeUntil,dropWhile,dropUntil,pry,
(++)
V.unsafeWith,sliceElt
#endif
) where
import Definitive.Base
......@@ -19,11 +21,13 @@ import qualified Data.ByteString.Lazy as Bytes
import qualified Data.ByteString as Chunk
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Internal as BSI
import qualified Prelude as P
import Unsafe.Coerce (unsafeCoerce)
#ifndef __HASTE__
import qualified Data.Vector.Storable as V
import Foreign.Storable (sizeOf)
import qualified Prelude as P
import Foreign.ForeignPtr (ForeignPtr,castForeignPtr)
import Unsafe.Coerce (unsafeCoerce)
#endif
class Monoid t => Sequence t where
splitAt :: Int -> t -> (t,t)
......@@ -35,9 +39,6 @@ drop = map2 snd splitAt
dropping :: Sequence t => Int -> Lens' t t
dropping n = lens (drop n) (\x y -> take n x+y)
instance V.Storable a => Semigroup (V.Vector a) where (+) = (V.++)
instance V.Storable a => Monoid (V.Vector a) where zero = V.empty
instance Sequence [a] where
splitAt n l = (h,t)
where ~(h,t) = case (n,l) of
......@@ -49,8 +50,6 @@ instance Sequence Bytes where
splitAt = Bytes.splitAt . fromIntegral
instance Sequence Chunk where
splitAt = Chunk.splitAt . fromIntegral
instance V.Storable a => Sequence (V.Vector a) where
splitAt = V.splitAt
class Stream c s | s -> c where
uncons :: s -> Maybe (c,s)
......@@ -66,6 +65,47 @@ instance Stream Word8 Bytes where
uncons = Bytes.uncons
cons = Bytes.cons
span :: Stream c s => (c -> Bool) -> s -> ([c],s)
span p = fix $ \f s -> (case uncons s of
Just (a,t) | p a -> let ~(l,t') = f t in (a:l,t')
_ -> ([],s))
break :: Stream c s => (c -> Bool) -> s -> ([c],s)
break = span . map not
takeWhile :: Stream c s => (c -> Bool) -> s -> [c]
takeWhile p = fst . span p
dropWhile :: Stream c s => (c -> Bool) -> s -> s
dropWhile p = snd . span p
takeUntil :: Stream c s => (c -> Bool) -> s -> [c]
takeUntil = takeWhile . map not
dropUntil :: Stream c s => (c -> Bool) -> s -> s
dropUntil = dropWhile . map not
pry :: Stream c s => Int -> s -> ([c],s)
pry 0 s = ([],s)
pry n s = case uncons s of
Just (a,s') -> let ~(t,l') = pry (n-1) s' in (a:t,l')
Nothing -> ([],s)
(++) :: Stream c s => [c] -> s -> s
(a:t) ++ c = cons a (t++c)
[] ++ c = c
i'elems :: (Monoid s',Stream c s,Stream c' s') => Iso [c] [c'] s s'
i'elems = iso (takeUntil (const False)) (++zero)
newtype StreamC a = StreamC (forall x. (a -> x -> x) -> x)
instance Stream a (StreamC a) where
cons a (StreamC l) = StreamC (\c -> c a (l c))
uncons (StreamC l) = Just (l const,l (flip const))
#ifndef __HASTE__
instance V.Storable a => Semigroup (V.Vector a) where (+) = (V.++)
instance V.Storable a => Monoid (V.Vector a) where zero = V.empty
instance V.Storable a => Sequence (V.Vector a) where
splitAt = V.splitAt
type Slice a = V.Vector a
i'storables :: forall a b. (V.Storable a,V.Storable b) => Iso (Slice a) (Slice b) Chunk Chunk
i'storables = iso toV fromV
......@@ -113,37 +153,4 @@ sliceElt f = V.mapM (unsafeCoerce f) <&> runPMonad
breadth :: V.Storable a => Slices a -> Int
breadth s = s^.._Slices & foldMap V.length
span :: Stream c s => (c -> Bool) -> s -> ([c],s)
span p = fix $ \f s -> (case uncons s of
Just (a,t) | p a -> let ~(l,t') = f t in (a:l,t')
_ -> ([],s))
break :: Stream c s => (c -> Bool) -> s -> ([c],s)
break = span . map not
takeWhile :: Stream c s => (c -> Bool) -> s -> [c]
takeWhile p = fst . span p
dropWhile :: Stream c s => (c -> Bool) -> s -> s
dropWhile p = snd . span p
takeUntil :: Stream c s => (c -> Bool) -> s -> [c]
takeUntil = takeWhile . map not
dropUntil :: Stream c s => (c -> Bool) -> s -> s
dropUntil = dropWhile . map not
pry :: Stream c s => Int -> s -> ([c],s)
pry 0 s = ([],s)
pry n s = case uncons s of
Just (a,s') -> let ~(t,l') = pry (n-1) s' in (a:t,l')
Nothing -> ([],s)
(++) :: Stream c s => [c] -> s -> s
(a:t) ++ c = cons a (t++c)
[] ++ c = c
i'elems :: (Monoid s',Stream c s,Stream c' s') => Iso [c] [c'] s s'
i'elems = iso (takeUntil (const False)) (++zero)
newtype StreamC a = StreamC (forall x. (a -> x -> x) -> x)
instance Stream a (StreamC a) where
cons a (StreamC l) = StreamC (\c -> c a (l c))
uncons (StreamC l) = Just (l const,l (flip const))
#endif -- __HASTE__
{-# LANGUAGE ImplicitParams, StandaloneDeriving #-}
{-# LANGUAGE ImplicitParams, StandaloneDeriving, CPP #-}
module Definitive (
module Definitive.Base,
module Data.Containers,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment